diff options
| author | Bastien | 2017-07-03 09:06:29 +0200 |
|---|---|---|
| committer | Bastien | 2017-07-03 09:06:29 +0200 |
| commit | 5ca1888fe670aee7febd4d42665d7372ab2ffebc (patch) | |
| tree | 1f7f8d8a7580e556fc83cf3a6aaeec567b33a090 /lisp | |
| parent | 20e006ffee41062f1b551a92c24d9edc53cd0f56 (diff) | |
| parent | 1b4f0a92ff3505ef9a465b9b391756e3a73a6443 (diff) | |
| download | emacs-5ca1888fe670aee7febd4d42665d7372ab2ffebc.tar.gz emacs-5ca1888fe670aee7febd4d42665d7372ab2ffebc.zip | |
Merge branch 'master' into scratch/org-mode-merge
Diffstat (limited to 'lisp')
43 files changed, 2001 insertions, 1143 deletions
diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 79291624523..a15386aa1af 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el | |||
| @@ -319,10 +319,12 @@ the list of old buffers.") | |||
| 319 | (defvar auto-revert-tail-pos 0 | 319 | (defvar auto-revert-tail-pos 0 |
| 320 | "Position of last known end of file.") | 320 | "Position of last known end of file.") |
| 321 | 321 | ||
| 322 | (defun auto-revert-find-file-function () | ||
| 323 | (setq-local auto-revert-tail-pos | ||
| 324 | (nth 7 (file-attributes buffer-file-name)))) | ||
| 325 | |||
| 322 | (add-hook 'find-file-hook | 326 | (add-hook 'find-file-hook |
| 323 | (lambda () | 327 | #'auto-revert-find-file-function) |
| 324 | (setq-local auto-revert-tail-pos | ||
| 325 | (nth 7 (file-attributes buffer-file-name))))) | ||
| 326 | 328 | ||
| 327 | (defvar auto-revert-notify-watch-descriptor-hash-list | 329 | (defvar auto-revert-notify-watch-descriptor-hash-list |
| 328 | (make-hash-table :test 'equal) | 330 | (make-hash-table :test 'equal) |
| @@ -341,6 +343,11 @@ This has been reported by a file notification event.") | |||
| 341 | 343 | ||
| 342 | ;; Functions: | 344 | ;; Functions: |
| 343 | 345 | ||
| 346 | (defun auto-revert-remove-current-buffer () | ||
| 347 | "Remove dead buffer from `auto-revert-buffer-list'." | ||
| 348 | (setq auto-revert-buffer-list | ||
| 349 | (delq (current-buffer) auto-revert-buffer-list))) | ||
| 350 | |||
| 344 | ;;;###autoload | 351 | ;;;###autoload |
| 345 | (define-minor-mode auto-revert-mode | 352 | (define-minor-mode auto-revert-mode |
| 346 | "Toggle reverting buffer when the file changes (Auto-Revert Mode). | 353 | "Toggle reverting buffer when the file changes (Auto-Revert Mode). |
| @@ -364,13 +371,10 @@ without being changed in the part that is already in the buffer." | |||
| 364 | (push (current-buffer) auto-revert-buffer-list) | 371 | (push (current-buffer) auto-revert-buffer-list) |
| 365 | (add-hook | 372 | (add-hook |
| 366 | 'kill-buffer-hook | 373 | 'kill-buffer-hook |
| 367 | (lambda () | 374 | #'auto-revert-remove-current-buffer |
| 368 | (setq auto-revert-buffer-list | ||
| 369 | (delq (current-buffer) auto-revert-buffer-list))) | ||
| 370 | nil t)) | 375 | nil t)) |
| 371 | (when auto-revert-use-notify (auto-revert-notify-rm-watch)) | 376 | (when auto-revert-use-notify (auto-revert-notify-rm-watch)) |
| 372 | (setq auto-revert-buffer-list | 377 | (auto-revert-remove-current-buffer)) |
| 373 | (delq (current-buffer) auto-revert-buffer-list))) | ||
| 374 | (auto-revert-set-timer) | 378 | (auto-revert-set-timer) |
| 375 | (when auto-revert-mode | 379 | (when auto-revert-mode |
| 376 | (auto-revert-buffers) | 380 | (auto-revert-buffers) |
| @@ -786,24 +790,24 @@ the timer when no buffers need to be checked." | |||
| 786 | (not (and auto-revert-stop-on-user-input | 790 | (not (and auto-revert-stop-on-user-input |
| 787 | (input-pending-p)))) | 791 | (input-pending-p)))) |
| 788 | (let ((buf (car bufs))) | 792 | (let ((buf (car bufs))) |
| 789 | (if (buffer-live-p buf) | 793 | (with-current-buffer buf |
| 790 | (with-current-buffer buf | 794 | (if (buffer-live-p buf) |
| 791 | ;; Test if someone has turned off Auto-Revert Mode in a | 795 | (progn |
| 792 | ;; non-standard way, for example by changing major mode. | 796 | ;; Test if someone has turned off Auto-Revert Mode |
| 793 | (if (and (not auto-revert-mode) | 797 | ;; in a non-standard way, for example by changing |
| 794 | (not auto-revert-tail-mode) | 798 | ;; major mode. |
| 795 | (memq buf auto-revert-buffer-list)) | 799 | (if (and (not auto-revert-mode) |
| 796 | (setq auto-revert-buffer-list | 800 | (not auto-revert-tail-mode) |
| 797 | (delq buf auto-revert-buffer-list))) | 801 | (memq buf auto-revert-buffer-list)) |
| 798 | (when (auto-revert-active-p) | 802 | (auto-revert-remove-current-buffer)) |
| 799 | ;; Enable file notification. | 803 | (when (auto-revert-active-p) |
| 800 | (when (and auto-revert-use-notify | 804 | ;; Enable file notification. |
| 801 | (not auto-revert-notify-watch-descriptor)) | 805 | (when (and auto-revert-use-notify |
| 802 | (auto-revert-notify-add-watch)) | 806 | (not auto-revert-notify-watch-descriptor)) |
| 803 | (auto-revert-handler))) | 807 | (auto-revert-notify-add-watch)) |
| 804 | ;; Remove dead buffer from `auto-revert-buffer-list'. | 808 | (auto-revert-handler))) |
| 805 | (setq auto-revert-buffer-list | 809 | ;; Remove dead buffer from `auto-revert-buffer-list'. |
| 806 | (delq buf auto-revert-buffer-list)))) | 810 | (auto-revert-remove-current-buffer)))) |
| 807 | (setq bufs (cdr bufs))) | 811 | (setq bufs (cdr bufs))) |
| 808 | (setq auto-revert-remaining-buffers bufs) | 812 | (setq auto-revert-remaining-buffers bufs) |
| 809 | ;; Check if we should cancel the timer. | 813 | ;; Check if we should cancel the timer. |
diff --git a/lisp/calc/calc-units.el b/lisp/calc/calc-units.el index 0e3715eb4cf..a8074eaeb20 100644 --- a/lisp/calc/calc-units.el +++ b/lisp/calc/calc-units.el | |||
| @@ -825,21 +825,18 @@ If COMP or STD is non-nil, put that in the units table instead." | |||
| 825 | (forward-char -1)) | 825 | (forward-char -1)) |
| 826 | (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") | 826 | (insert ";;; Custom units stored by Calc on " (current-time-string) "\n") |
| 827 | (if math-additional-units | 827 | (if math-additional-units |
| 828 | (progn | 828 | (let (expr) |
| 829 | (insert "(setq math-additional-units '(\n") | 829 | (insert "(setq math-additional-units '(\n") |
| 830 | (let ((list math-additional-units)) | 830 | (dolist (u math-additional-units) |
| 831 | (while list | 831 | (insert " (" (symbol-name (car u)) " " |
| 832 | (insert " (" (symbol-name (car (car list))) " " | 832 | (if (setq expr (nth 1 u)) |
| 833 | (if (nth 1 (car list)) | 833 | (if (stringp expr) |
| 834 | (if (stringp (nth 1 (car list))) | 834 | (prin1-to-string expr) |
| 835 | (prin1-to-string (nth 1 (car list))) | 835 | (prin1-to-string (math-format-flat-expr expr 0))) |
| 836 | (prin1-to-string (math-format-flat-expr | 836 | "nil") |
| 837 | (nth 1 (car list)) 0))) | 837 | " " |
| 838 | "nil") | 838 | (prin1-to-string (nth 2 u)) |
| 839 | " " | 839 | ")\n")) |
| 840 | (prin1-to-string (nth 2 (car list))) | ||
| 841 | ")\n") | ||
| 842 | (setq list (cdr list)))) | ||
| 843 | (insert "))\n")) | 840 | (insert "))\n")) |
| 844 | (insert ";;; (no custom units defined)\n")) | 841 | (insert ";;; (no custom units defined)\n")) |
| 845 | (insert ";;; End of custom units\n") | 842 | (insert ";;; End of custom units\n") |
| @@ -916,15 +913,13 @@ If COMP or STD is non-nil, put that in the units table instead." | |||
| 916 | (defun math-find-base-units-rec (expr pow) | 913 | (defun math-find-base-units-rec (expr pow) |
| 917 | (let ((u (math-check-unit-name expr))) | 914 | (let ((u (math-check-unit-name expr))) |
| 918 | (cond (u | 915 | (cond (u |
| 919 | (let ((ulist (math-find-base-units u))) | 916 | (dolist (x (math-find-base-units u)) |
| 920 | (while ulist | 917 | (let ((p (* (cdr x) pow)) |
| 921 | (let ((p (* (cdr (car ulist)) pow)) | 918 | (old (assq (car x) math-fbu-base))) |
| 922 | (old (assq (car (car ulist)) math-fbu-base))) | 919 | (if old |
| 923 | (if old | 920 | (setcdr old (+ (cdr old) p)) |
| 924 | (setcdr old (+ (cdr old) p)) | 921 | (setq math-fbu-base |
| 925 | (setq math-fbu-base | 922 | (cons (cons (car x) p) math-fbu-base)))))) |
| 926 | (cons (cons (car (car ulist)) p) math-fbu-base)))) | ||
| 927 | (setq ulist (cdr ulist))))) | ||
| 928 | ((math-scalarp expr)) | 923 | ((math-scalarp expr)) |
| 929 | ((and (eq (car expr) '^) | 924 | ((and (eq (car expr) '^) |
| 930 | (integerp (nth 2 expr))) | 925 | (integerp (nth 2 expr))) |
| @@ -1377,20 +1372,15 @@ If COMP or STD is non-nil, put that in the units table instead." | |||
| 1377 | (if (eq pow1 1) | 1372 | (if (eq pow1 1) |
| 1378 | (math-to-standard-units (list '/ n d) nil) | 1373 | (math-to-standard-units (list '/ n d) nil) |
| 1379 | (list '^ (math-to-standard-units (list '/ n d) nil) pow1)) | 1374 | (list '^ (math-to-standard-units (list '/ n d) nil) pow1)) |
| 1380 | (let (ud1) | 1375 | (setq un (nth 4 un) |
| 1381 | (setq un (nth 4 un) | 1376 | ud (nth 4 ud)) |
| 1382 | ud (nth 4 ud)) | 1377 | (dolist (x un) |
| 1383 | (while un | 1378 | (dolist (y ud) |
| 1384 | (setq ud1 ud) | 1379 | (when (eq (car x) (car y)) |
| 1385 | (while ud1 | 1380 | (setq math-try-cancel-units |
| 1386 | (and (eq (car (car un)) (car (car ud1))) | 1381 | (+ math-try-cancel-units |
| 1387 | (setq math-try-cancel-units | 1382 | (- (* (cdr x) pow1) |
| 1388 | (+ math-try-cancel-units | 1383 | (* (cdr (car ud)) pow2)))))))))))) |
| 1389 | (- (* (cdr (car un)) pow1) | ||
| 1390 | (* (cdr (car ud)) pow2))))) | ||
| 1391 | (setq ud1 (cdr ud1))) | ||
| 1392 | (setq un (cdr un))) | ||
| 1393 | nil)))))) | ||
| 1394 | 1384 | ||
| 1395 | (math-defsimplify ^ | 1385 | (math-defsimplify ^ |
| 1396 | (and math-simplifying-units | 1386 | (and math-simplifying-units |
| @@ -1578,9 +1568,8 @@ If COMP or STD is non-nil, put that in the units table instead." | |||
| 1578 | (insert "Calculator Units Table:\n\n") | 1568 | (insert "Calculator Units Table:\n\n") |
| 1579 | (insert "(All definitions are exact unless marked with an asterisk (*).)\n\n") | 1569 | (insert "(All definitions are exact unless marked with an asterisk (*).)\n\n") |
| 1580 | (insert "Unit Type Definition Description\n\n") | 1570 | (insert "Unit Type Definition Description\n\n") |
| 1581 | (while uptr | 1571 | (dolist (u uptr) |
| 1582 | (setq u (car uptr) | 1572 | (setq name (nth 2 u)) |
| 1583 | name (nth 2 u)) | ||
| 1584 | (when (eq (car u) 'm) | 1573 | (when (eq (car u) 'm) |
| 1585 | (setq std t)) | 1574 | (setq std t)) |
| 1586 | (setq shadowed (and std (assq (car u) math-additional-units))) | 1575 | (setq shadowed (and std (assq (car u) math-additional-units))) |
| @@ -1618,8 +1607,7 @@ If COMP or STD is non-nil, put that in the units table instead." | |||
| 1618 | (insert " (redefined above)") | 1607 | (insert " (redefined above)") |
| 1619 | (unless (nth 1 u) | 1608 | (unless (nth 1 u) |
| 1620 | (insert " (base unit)"))) | 1609 | (insert " (base unit)"))) |
| 1621 | (insert "\n") | 1610 | (insert "\n")) |
| 1622 | (setq uptr (cdr uptr))) | ||
| 1623 | (insert "\n\nUnit Prefix Table:\n\n") | 1611 | (insert "\n\nUnit Prefix Table:\n\n") |
| 1624 | (setq uptr math-unit-prefixes) | 1612 | (setq uptr math-unit-prefixes) |
| 1625 | (while uptr | 1613 | (while uptr |
diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 6a6a8ea4479..6f36bbed680 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el | |||
| @@ -413,12 +413,11 @@ relevant to POS." | |||
| 413 | (multibyte-p enable-multibyte-characters) | 413 | (multibyte-p enable-multibyte-characters) |
| 414 | (overlays (mapcar (lambda (o) (overlay-properties o)) | 414 | (overlays (mapcar (lambda (o) (overlay-properties o)) |
| 415 | (overlays-at pos))) | 415 | (overlays-at pos))) |
| 416 | (char-description (if (not multibyte-p) | 416 | (char-description (if (< char 128) |
| 417 | (single-key-description char) | 417 | (single-key-description char) |
| 418 | (if (< char 128) | 418 | (string (if (not multibyte-p) |
| 419 | (single-key-description char) | 419 | (decode-char 'eight-bit char) |
| 420 | (string-to-multibyte | 420 | char)))) |
| 421 | (char-to-string char))))) | ||
| 422 | (text-props-desc | 421 | (text-props-desc |
| 423 | (let ((tmp-buf (generate-new-buffer " *text-props*"))) | 422 | (let ((tmp-buf (generate-new-buffer " *text-props*"))) |
| 424 | (unwind-protect | 423 | (unwind-protect |
| @@ -635,7 +634,9 @@ relevant to POS." | |||
| 635 | ("buffer code" | 634 | ("buffer code" |
| 636 | ,(if multibyte-p | 635 | ,(if multibyte-p |
| 637 | (encoded-string-description | 636 | (encoded-string-description |
| 638 | (string-as-unibyte (char-to-string char)) nil) | 637 | (encode-coding-string (char-to-string char) |
| 638 | 'emacs-internal) | ||
| 639 | nil) | ||
| 639 | (format "#x%02X" char))) | 640 | (format "#x%02X" char))) |
| 640 | ("file code" | 641 | ("file code" |
| 641 | ,@(if multibyte-p | 642 | ,@(if multibyte-p |
| @@ -704,7 +705,6 @@ relevant to POS." | |||
| 704 | (called-interactively-p 'interactive)) | 705 | (called-interactively-p 'interactive)) |
| 705 | (with-help-window (help-buffer) | 706 | (with-help-window (help-buffer) |
| 706 | (with-current-buffer standard-output | 707 | (with-current-buffer standard-output |
| 707 | (set-buffer-multibyte multibyte-p) | ||
| 708 | (let ((formatter (format "%%%ds:" max-width))) | 708 | (let ((formatter (format "%%%ds:" max-width))) |
| 709 | (dolist (elt item-list) | 709 | (dolist (elt item-list) |
| 710 | (when (cadr elt) | 710 | (when (cadr elt) |
diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index ec07f9bf735..12a97f8457e 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el | |||
| @@ -51,6 +51,33 @@ into this list; they also should call `dired-log' to log the errors.") | |||
| 51 | 51 | ||
| 52 | (defconst dired-star-subst-regexp "\\(^\\|[ \t]\\)\\*\\([ \t]\\|$\\)") | 52 | (defconst dired-star-subst-regexp "\\(^\\|[ \t]\\)\\*\\([ \t]\\|$\\)") |
| 53 | (defconst dired-quark-subst-regexp "\\(^\\|[ \t]\\)\\?\\([ \t]\\|$\\)") | 53 | (defconst dired-quark-subst-regexp "\\(^\\|[ \t]\\)\\?\\([ \t]\\|$\\)") |
| 54 | (make-obsolete-variable 'dired-star-subst-regexp nil "26.1") | ||
| 55 | (make-obsolete-variable 'dired-quark-subst-regexp nil "26.1") | ||
| 56 | |||
| 57 | (defun dired-isolated-string-re (string) | ||
| 58 | "Return a regexp to match STRING isolated. | ||
| 59 | Isolated means that STRING is surrounded by spaces or at the beginning/end | ||
| 60 | of a string followed/prefixed with an space. | ||
| 61 | The regexp capture the preceding blank, STRING and the following blank as | ||
| 62 | the groups 1, 2 and 3 respectively." | ||
| 63 | (format "\\(\\`\\|[ \t]\\)\\(%s\\)\\([ \t]\\|\\'\\)" string)) | ||
| 64 | |||
| 65 | (defun dired--star-or-qmark-p (string match &optional keep) | ||
| 66 | "Return non-nil if STRING contains isolated MATCH or `\\=`?\\=`'. | ||
| 67 | MATCH should be the strings \"?\", `\\=`?\\=`', \"*\" or nil. The latter | ||
| 68 | means STRING contains either \"?\" or `\\=`?\\=`' or \"*\". | ||
| 69 | If optional arg KEEP is non-nil, then preserve the match data. Otherwise, | ||
| 70 | this function changes it and saves MATCH as the second match group. | ||
| 71 | |||
| 72 | Isolated means that MATCH is surrounded by spaces or at the beginning/end | ||
| 73 | of STRING followed/prefixed with an space. A match to `\\=`?\\=`', | ||
| 74 | isolated or not, is also valid." | ||
| 75 | (let ((regexps (list (dired-isolated-string-re (if match (regexp-quote match) "[*?]"))))) | ||
| 76 | (when (or (null match) (equal match "?")) | ||
| 77 | (setq regexps (append (list "\\(\\)\\(`\\?`\\)\\(\\)") regexps))) | ||
| 78 | (cl-some (lambda (x) | ||
| 79 | (funcall (if keep #'string-match-p #'string-match) x string)) | ||
| 80 | regexps))) | ||
| 54 | 81 | ||
| 55 | ;;;###autoload | 82 | ;;;###autoload |
| 56 | (defun dired-diff (file &optional switches) | 83 | (defun dired-diff (file &optional switches) |
| @@ -308,7 +335,7 @@ List has a form of (file-name full-file-name (attribute-list))." | |||
| 308 | failures) | 335 | failures) |
| 309 | (setq failures | 336 | (setq failures |
| 310 | (dired-bunch-files 10000 | 337 | (dired-bunch-files 10000 |
| 311 | (function dired-check-process) | 338 | #'dired-check-process |
| 312 | (append | 339 | (append |
| 313 | (list operation program) | 340 | (list operation program) |
| 314 | (unless (or (string-equal new-attribute "") | 341 | (unless (or (string-equal new-attribute "") |
| @@ -512,7 +539,7 @@ with a prefix argument." | |||
| 512 | ;; If the file has numeric backup versions, | 539 | ;; If the file has numeric backup versions, |
| 513 | ;; put on dired-file-version-alist an element of the form | 540 | ;; put on dired-file-version-alist an element of the form |
| 514 | ;; (FILENAME . VERSION-NUMBER-LIST) | 541 | ;; (FILENAME . VERSION-NUMBER-LIST) |
| 515 | (dired-map-dired-file-lines (function dired-collect-file-versions)) | 542 | (dired-map-dired-file-lines #'dired-collect-file-versions) |
| 516 | ;; Sort each VERSION-NUMBER-LIST, | 543 | ;; Sort each VERSION-NUMBER-LIST, |
| 517 | ;; and remove the versions not to be deleted. | 544 | ;; and remove the versions not to be deleted. |
| 518 | (let ((fval dired-file-version-alist)) | 545 | (let ((fval dired-file-version-alist)) |
| @@ -528,7 +555,7 @@ with a prefix argument." | |||
| 528 | (setq fval (cdr fval)))) | 555 | (setq fval (cdr fval)))) |
| 529 | ;; Look at each file. If it is a numeric backup file, | 556 | ;; Look at each file. If it is a numeric backup file, |
| 530 | ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. | 557 | ;; find it in a VERSION-NUMBER-LIST and maybe flag it for deletion. |
| 531 | (dired-map-dired-file-lines (function dired-trample-file-versions)) | 558 | (dired-map-dired-file-lines #'dired-trample-file-versions) |
| 532 | (message "Cleaning numerical backups...done"))) | 559 | (message "Cleaning numerical backups...done"))) |
| 533 | 560 | ||
| 534 | ;;; Subroutines of dired-clean-directory. | 561 | ;;; Subroutines of dired-clean-directory. |
| @@ -658,13 +685,13 @@ If there is a `*' in COMMAND, surrounded by whitespace, this runs | |||
| 658 | COMMAND just once with the entire file list substituted there. | 685 | COMMAND just once with the entire file list substituted there. |
| 659 | 686 | ||
| 660 | If there is no `*', but there is a `?' in COMMAND, surrounded by | 687 | If there is no `*', but there is a `?' in COMMAND, surrounded by |
| 661 | whitespace, this runs COMMAND on each file individually with the | 688 | whitespace, or a `\\=`?\\=`' this runs COMMAND on each file |
| 662 | file name substituted for `?'. | 689 | individually with the file name substituted for `?' or `\\=`?\\=`'. |
| 663 | 690 | ||
| 664 | Otherwise, this runs COMMAND on each file individually with the | 691 | Otherwise, this runs COMMAND on each file individually with the |
| 665 | file name added at the end of COMMAND (separated by a space). | 692 | file name added at the end of COMMAND (separated by a space). |
| 666 | 693 | ||
| 667 | `*' and `?' when not surrounded by whitespace have no special | 694 | `*' and `?' when not surrounded by whitespace nor `\\=`' have no special |
| 668 | significance for `dired-do-shell-command', and are passed through | 695 | significance for `dired-do-shell-command', and are passed through |
| 669 | normally to the shell, but you must confirm first. | 696 | normally to the shell, but you must confirm first. |
| 670 | 697 | ||
| @@ -704,32 +731,40 @@ can be produced by `dired-get-marked-files', for example." | |||
| 704 | (dired-read-shell-command "! on %s: " current-prefix-arg files) | 731 | (dired-read-shell-command "! on %s: " current-prefix-arg files) |
| 705 | current-prefix-arg | 732 | current-prefix-arg |
| 706 | files))) | 733 | files))) |
| 707 | (let* ((on-each (not (string-match-p dired-star-subst-regexp command))) | 734 | (cl-flet ((need-confirm-p |
| 708 | (no-subst (not (string-match-p dired-quark-subst-regexp command))) | 735 | (cmd str) |
| 709 | (star (string-match-p "\\*" command)) | 736 | (let ((res cmd) |
| 710 | (qmark (string-match-p "\\?" command))) | 737 | (regexp (regexp-quote str))) |
| 711 | ;; Get confirmation for wildcards that may have been meant | 738 | ;; Drop all ? and * surrounded by spaces and `?`. |
| 712 | ;; to control substitution of a file name or the file name list. | 739 | (while (and (string-match regexp res) |
| 713 | (if (cond ((not (or on-each no-subst)) | 740 | (dired--star-or-qmark-p res str)) |
| 714 | (error "You can not combine `*' and `?' substitution marks")) | 741 | (setq res (replace-match "" t t res 0))) |
| 715 | ((and star on-each) | 742 | (string-match regexp res)))) |
| 716 | (y-or-n-p (format-message | 743 | (let* ((on-each (not (dired--star-or-qmark-p command "*" 'keep))) |
| 717 | "Confirm--do you mean to use `*' as a wildcard? "))) | 744 | (no-subst (not (dired--star-or-qmark-p command "?" 'keep))) |
| 718 | ((and qmark no-subst) | 745 | (star (string-match "\\*" command)) |
| 719 | (y-or-n-p (format-message | 746 | (qmark (string-match "\\?" command)) |
| 720 | "Confirm--do you mean to use `?' as a wildcard? "))) | 747 | ;; Get confirmation for wildcards that may have been meant |
| 721 | (t)) | 748 | ;; to control substitution of a file name or the file name list. |
| 722 | (if on-each | 749 | (ok (cond ((not (or on-each no-subst)) |
| 723 | (dired-bunch-files | 750 | (error "You can not combine `*' and `?' substitution marks")) |
| 724 | (- 10000 (length command)) | 751 | ((need-confirm-p command "*") |
| 725 | (function (lambda (&rest files) | 752 | (y-or-n-p (format-message |
| 726 | (dired-run-shell-command | 753 | "Confirm--do you mean to use `*' as a wildcard? "))) |
| 727 | (dired-shell-stuff-it command files t arg)))) | 754 | ((need-confirm-p command "?") |
| 728 | nil | 755 | (y-or-n-p (format-message |
| 729 | file-list) | 756 | "Confirm--do you mean to use `?' as a wildcard? "))) |
| 730 | ;; execute the shell command | 757 | (t)))) |
| 731 | (dired-run-shell-command | 758 | (when ok |
| 732 | (dired-shell-stuff-it command file-list nil arg)))))) | 759 | (if on-each |
| 760 | (dired-bunch-files (- 10000 (length command)) | ||
| 761 | (lambda (&rest files) | ||
| 762 | (dired-run-shell-command | ||
| 763 | (dired-shell-stuff-it command files t arg))) | ||
| 764 | nil file-list) | ||
| 765 | ;; execute the shell command | ||
| 766 | (dired-run-shell-command | ||
| 767 | (dired-shell-stuff-it command file-list nil arg))))))) | ||
| 733 | 768 | ||
| 734 | ;; Might use {,} for bash or csh: | 769 | ;; Might use {,} for bash or csh: |
| 735 | (defvar dired-mark-prefix "" | 770 | (defvar dired-mark-prefix "" |
| @@ -769,12 +804,10 @@ can be produced by `dired-get-marked-files', for example." | |||
| 769 | ";" | 804 | ";" |
| 770 | "&")) | 805 | "&")) |
| 771 | (stuff-it | 806 | (stuff-it |
| 772 | (if (or (string-match-p dired-star-subst-regexp command) | 807 | (if (dired--star-or-qmark-p command nil 'keep) |
| 773 | (string-match-p dired-quark-subst-regexp command)) | ||
| 774 | (lambda (x) | 808 | (lambda (x) |
| 775 | (let ((retval (concat cmd-prefix command))) | 809 | (let ((retval (concat cmd-prefix command))) |
| 776 | (while (string-match | 810 | (while (dired--star-or-qmark-p retval nil) |
| 777 | "\\(^\\|[ \t]\\)\\([*?]\\)\\([ \t]\\|$\\)" retval) | ||
| 778 | (setq retval (replace-match x t t retval 2))) | 811 | (setq retval (replace-match x t t retval 2))) |
| 779 | retval)) | 812 | retval)) |
| 780 | (lambda (x) (concat cmd-prefix command dired-mark-separator x))))) | 813 | (lambda (x) (concat cmd-prefix command dired-mark-separator x))))) |
| @@ -1122,7 +1155,7 @@ Return nil if no change in files." | |||
| 1122 | (let ((files (dired-get-marked-files t arg nil t)) | 1155 | (let ((files (dired-get-marked-files t arg nil t)) |
| 1123 | (string (if (eq op-symbol 'compress) "Compress or uncompress" | 1156 | (string (if (eq op-symbol 'compress) "Compress or uncompress" |
| 1124 | (capitalize (symbol-name op-symbol))))) | 1157 | (capitalize (symbol-name op-symbol))))) |
| 1125 | (dired-mark-pop-up nil op-symbol files (function y-or-n-p) | 1158 | (dired-mark-pop-up nil op-symbol files #'y-or-n-p |
| 1126 | (concat string " " | 1159 | (concat string " " |
| 1127 | (dired-mark-prompt arg files) "? "))))) | 1160 | (dired-mark-prompt arg files) "? "))))) |
| 1128 | 1161 | ||
| @@ -1190,7 +1223,7 @@ return t; if SYM is q or ESC, return nil." | |||
| 1190 | (defun dired-do-compress (&optional arg) | 1223 | (defun dired-do-compress (&optional arg) |
| 1191 | "Compress or uncompress marked (or next ARG) files." | 1224 | "Compress or uncompress marked (or next ARG) files." |
| 1192 | (interactive "P") | 1225 | (interactive "P") |
| 1193 | (dired-map-over-marks-check (function dired-compress) arg 'compress t)) | 1226 | (dired-map-over-marks-check #'dired-compress arg 'compress t)) |
| 1194 | 1227 | ||
| 1195 | ;; Commands for Emacs Lisp files - load and byte compile | 1228 | ;; Commands for Emacs Lisp files - load and byte compile |
| 1196 | 1229 | ||
| @@ -1218,7 +1251,7 @@ return t; if SYM is q or ESC, return nil." | |||
| 1218 | (defun dired-do-byte-compile (&optional arg) | 1251 | (defun dired-do-byte-compile (&optional arg) |
| 1219 | "Byte compile marked (or next ARG) Emacs Lisp files." | 1252 | "Byte compile marked (or next ARG) Emacs Lisp files." |
| 1220 | (interactive "P") | 1253 | (interactive "P") |
| 1221 | (dired-map-over-marks-check (function dired-byte-compile) arg 'byte-compile t)) | 1254 | (dired-map-over-marks-check #'dired-byte-compile arg 'byte-compile t)) |
| 1222 | 1255 | ||
| 1223 | (defun dired-load () | 1256 | (defun dired-load () |
| 1224 | ;; Return nil for success, offending file name else. | 1257 | ;; Return nil for success, offending file name else. |
| @@ -1235,7 +1268,7 @@ return t; if SYM is q or ESC, return nil." | |||
| 1235 | (defun dired-do-load (&optional arg) | 1268 | (defun dired-do-load (&optional arg) |
| 1236 | "Load the marked (or next ARG) Emacs Lisp files." | 1269 | "Load the marked (or next ARG) Emacs Lisp files." |
| 1237 | (interactive "P") | 1270 | (interactive "P") |
| 1238 | (dired-map-over-marks-check (function dired-load) arg 'load t)) | 1271 | (dired-map-over-marks-check #'dired-load arg 'load t)) |
| 1239 | 1272 | ||
| 1240 | ;;;###autoload | 1273 | ;;;###autoload |
| 1241 | (defun dired-do-redisplay (&optional arg test-for-subdir) | 1274 | (defun dired-do-redisplay (&optional arg test-for-subdir) |
| @@ -1308,7 +1341,7 @@ See Info node `(emacs)Subdir switches' for more details." | |||
| 1308 | (defun dired-add-file (filename &optional marker-char) | 1341 | (defun dired-add-file (filename &optional marker-char) |
| 1309 | (dired-fun-in-all-buffers | 1342 | (dired-fun-in-all-buffers |
| 1310 | (file-name-directory filename) (file-name-nondirectory filename) | 1343 | (file-name-directory filename) (file-name-nondirectory filename) |
| 1311 | (function dired-add-entry) filename marker-char)) | 1344 | #'dired-add-entry filename marker-char)) |
| 1312 | 1345 | ||
| 1313 | (defvar dired-omit-mode) | 1346 | (defvar dired-omit-mode) |
| 1314 | (declare-function dired-omit-regexp "dired-x" ()) | 1347 | (declare-function dired-omit-regexp "dired-x" ()) |
| @@ -1445,7 +1478,7 @@ files matching `dired-omit-regexp'." | |||
| 1445 | (defun dired-remove-file (file) | 1478 | (defun dired-remove-file (file) |
| 1446 | (dired-fun-in-all-buffers | 1479 | (dired-fun-in-all-buffers |
| 1447 | (file-name-directory file) (file-name-nondirectory file) | 1480 | (file-name-directory file) (file-name-nondirectory file) |
| 1448 | (function dired-remove-entry) file)) | 1481 | #'dired-remove-entry file)) |
| 1449 | 1482 | ||
| 1450 | (defun dired-remove-entry (file) | 1483 | (defun dired-remove-entry (file) |
| 1451 | (save-excursion | 1484 | (save-excursion |
| @@ -1459,7 +1492,7 @@ files matching `dired-omit-regexp'." | |||
| 1459 | "Create or update the line for FILE in all Dired buffers it would belong in." | 1492 | "Create or update the line for FILE in all Dired buffers it would belong in." |
| 1460 | (dired-fun-in-all-buffers (file-name-directory file) | 1493 | (dired-fun-in-all-buffers (file-name-directory file) |
| 1461 | (file-name-nondirectory file) | 1494 | (file-name-nondirectory file) |
| 1462 | (function dired-relist-entry) file)) | 1495 | #'dired-relist-entry file)) |
| 1463 | 1496 | ||
| 1464 | (defun dired-relist-entry (file) | 1497 | (defun dired-relist-entry (file) |
| 1465 | ;; Relist the line for FILE, or just add it if it did not exist. | 1498 | ;; Relist the line for FILE, or just add it if it did not exist. |
| @@ -1553,7 +1586,7 @@ Special value `always' suppresses confirmation." | |||
| 1553 | (setq from-dir (file-name-as-directory from-dir) | 1586 | (setq from-dir (file-name-as-directory from-dir) |
| 1554 | to-dir (file-name-as-directory to-dir)) | 1587 | to-dir (file-name-as-directory to-dir)) |
| 1555 | (dired-fun-in-all-buffers from-dir nil | 1588 | (dired-fun-in-all-buffers from-dir nil |
| 1556 | (function dired-rename-subdir-1) from-dir to-dir) | 1589 | #'dired-rename-subdir-1 from-dir to-dir) |
| 1557 | ;; Update visited file name of all affected buffers | 1590 | ;; Update visited file name of all affected buffers |
| 1558 | (let ((expanded-from-dir (expand-file-name from-dir)) | 1591 | (let ((expanded-from-dir (expand-file-name from-dir)) |
| 1559 | (blist (buffer-list))) | 1592 | (blist (buffer-list))) |
| @@ -1788,7 +1821,7 @@ Optional arg HOW-TO determines how to treat the target. | |||
| 1788 | For any other return value, TARGET is treated as a directory." | 1821 | For any other return value, TARGET is treated as a directory." |
| 1789 | (or op1 (setq op1 operation)) | 1822 | (or op1 (setq op1 operation)) |
| 1790 | (let* ((fn-list (dired-get-marked-files nil arg)) | 1823 | (let* ((fn-list (dired-get-marked-files nil arg)) |
| 1791 | (rfn-list (mapcar (function dired-make-relative) fn-list)) | 1824 | (rfn-list (mapcar #'dired-make-relative fn-list)) |
| 1792 | (dired-one-file ; fluid variable inside dired-create-files | 1825 | (dired-one-file ; fluid variable inside dired-create-files |
| 1793 | (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) | 1826 | (and (consp fn-list) (null (cdr fn-list)) (car fn-list))) |
| 1794 | (target-dir (dired-dwim-target-directory)) | 1827 | (target-dir (dired-dwim-target-directory)) |
| @@ -1838,10 +1871,9 @@ Optional arg HOW-TO determines how to treat the target. | |||
| 1838 | (if into-dir ; target is a directory | 1871 | (if into-dir ; target is a directory |
| 1839 | ;; This function uses fluid variable target when called | 1872 | ;; This function uses fluid variable target when called |
| 1840 | ;; inside dired-create-files: | 1873 | ;; inside dired-create-files: |
| 1841 | (function | 1874 | (lambda (from) |
| 1842 | (lambda (from) | 1875 | (expand-file-name (file-name-nondirectory from) target)) |
| 1843 | (expand-file-name (file-name-nondirectory from) target))) | 1876 | (lambda (_from) target)) |
| 1844 | (function (lambda (_from) target))) | ||
| 1845 | marker-char)))) | 1877 | marker-char)))) |
| 1846 | 1878 | ||
| 1847 | ;; Read arguments for a marked-files command that wants a file name, | 1879 | ;; Read arguments for a marked-files command that wants a file name, |
| @@ -1857,7 +1889,7 @@ Optional arg HOW-TO determines how to treat the target. | |||
| 1857 | &optional default) | 1889 | &optional default) |
| 1858 | (dired-mark-pop-up | 1890 | (dired-mark-pop-up |
| 1859 | nil op-symbol files | 1891 | nil op-symbol files |
| 1860 | (function read-file-name) | 1892 | #'read-file-name |
| 1861 | (format prompt (dired-mark-prompt arg files)) dir default)) | 1893 | (format prompt (dired-mark-prompt arg files)) dir default)) |
| 1862 | 1894 | ||
| 1863 | (defun dired-dwim-target-directory () | 1895 | (defun dired-dwim-target-directory () |
| @@ -1985,7 +2017,7 @@ This command copies symbolic links by creating new ones, similar | |||
| 1985 | to the \"-d\" option for the \"cp\" shell command." | 2017 | to the \"-d\" option for the \"cp\" shell command." |
| 1986 | (interactive "P") | 2018 | (interactive "P") |
| 1987 | (let ((dired-recursive-copies dired-recursive-copies)) | 2019 | (let ((dired-recursive-copies dired-recursive-copies)) |
| 1988 | (dired-do-create-files 'copy (function dired-copy-file) | 2020 | (dired-do-create-files 'copy #'dired-copy-file |
| 1989 | "Copy" | 2021 | "Copy" |
| 1990 | arg dired-keep-marker-copy | 2022 | arg dired-keep-marker-copy |
| 1991 | nil dired-copy-how-to-fn))) | 2023 | nil dired-copy-how-to-fn))) |
| @@ -2002,7 +2034,7 @@ suggested for the target directory depends on the value of | |||
| 2002 | 2034 | ||
| 2003 | For relative symlinks, use \\[dired-do-relsymlink]." | 2035 | For relative symlinks, use \\[dired-do-relsymlink]." |
| 2004 | (interactive "P") | 2036 | (interactive "P") |
| 2005 | (dired-do-create-files 'symlink (function make-symbolic-link) | 2037 | (dired-do-create-files 'symlink #'make-symbolic-link |
| 2006 | "Symlink" arg dired-keep-marker-symlink)) | 2038 | "Symlink" arg dired-keep-marker-symlink)) |
| 2007 | 2039 | ||
| 2008 | ;;;###autoload | 2040 | ;;;###autoload |
| @@ -2015,7 +2047,7 @@ with the same names that the files currently have. The default | |||
| 2015 | suggested for the target directory depends on the value of | 2047 | suggested for the target directory depends on the value of |
| 2016 | `dired-dwim-target', which see." | 2048 | `dired-dwim-target', which see." |
| 2017 | (interactive "P") | 2049 | (interactive "P") |
| 2018 | (dired-do-create-files 'hardlink (function dired-hardlink) | 2050 | (dired-do-create-files 'hardlink #'dired-hardlink |
| 2019 | "Hardlink" arg dired-keep-marker-hardlink)) | 2051 | "Hardlink" arg dired-keep-marker-hardlink)) |
| 2020 | 2052 | ||
| 2021 | (defun dired-hardlink (file newname &optional ok-if-already-exists) | 2053 | (defun dired-hardlink (file newname &optional ok-if-already-exists) |
| @@ -2034,7 +2066,7 @@ This command also renames any buffers that are visiting the files. | |||
| 2034 | The default suggested for the target directory depends on the value | 2066 | The default suggested for the target directory depends on the value |
| 2035 | of `dired-dwim-target', which see." | 2067 | of `dired-dwim-target', which see." |
| 2036 | (interactive "P") | 2068 | (interactive "P") |
| 2037 | (dired-do-create-files 'move (function dired-rename-file) | 2069 | (dired-do-create-files 'move #'dired-rename-file |
| 2038 | "Move" arg dired-keep-marker-rename "Rename")) | 2070 | "Move" arg dired-keep-marker-rename "Rename")) |
| 2039 | ;;;###end dired-cp.el | 2071 | ;;;###end dired-cp.el |
| 2040 | 2072 | ||
| @@ -2062,37 +2094,35 @@ Type SPC or `y' to %s one match, DEL or `n' to skip to next, | |||
| 2062 | (regexp-name-constructor | 2094 | (regexp-name-constructor |
| 2063 | ;; Function to construct new filename using REGEXP and NEWNAME: | 2095 | ;; Function to construct new filename using REGEXP and NEWNAME: |
| 2064 | (if whole-name ; easy (but rare) case | 2096 | (if whole-name ; easy (but rare) case |
| 2065 | (function | 2097 | (lambda (from) |
| 2066 | (lambda (from) | 2098 | (let ((to (dired-string-replace-match regexp from newname)) |
| 2067 | (let ((to (dired-string-replace-match regexp from newname)) | 2099 | ;; must bind help-form directly around call to |
| 2068 | ;; must bind help-form directly around call to | 2100 | ;; dired-query |
| 2069 | ;; dired-query | ||
| 2070 | (help-form rename-regexp-help-form)) | ||
| 2071 | (if to | ||
| 2072 | (and (dired-query 'rename-regexp-query | ||
| 2073 | operation-prompt | ||
| 2074 | from | ||
| 2075 | to) | ||
| 2076 | to) | ||
| 2077 | (dired-log "%s: %s did not match regexp %s\n" | ||
| 2078 | operation from regexp))))) | ||
| 2079 | ;; not whole-name, replace non-directory part only | ||
| 2080 | (function | ||
| 2081 | (lambda (from) | ||
| 2082 | (let* ((new (dired-string-replace-match | ||
| 2083 | regexp (file-name-nondirectory from) newname)) | ||
| 2084 | (to (and new ; nil means there was no match | ||
| 2085 | (expand-file-name new | ||
| 2086 | (file-name-directory from)))) | ||
| 2087 | (help-form rename-regexp-help-form)) | 2101 | (help-form rename-regexp-help-form)) |
| 2088 | (if to | 2102 | (if to |
| 2089 | (and (dired-query 'rename-regexp-query | 2103 | (and (dired-query 'rename-regexp-query |
| 2090 | operation-prompt | 2104 | operation-prompt |
| 2091 | (dired-make-relative from) | 2105 | from |
| 2092 | (dired-make-relative to)) | 2106 | to) |
| 2093 | to) | 2107 | to) |
| 2094 | (dired-log "%s: %s did not match regexp %s\n" | 2108 | (dired-log "%s: %s did not match regexp %s\n" |
| 2095 | operation (file-name-nondirectory from) regexp))))))) | 2109 | operation from regexp)))) |
| 2110 | ;; not whole-name, replace non-directory part only | ||
| 2111 | (lambda (from) | ||
| 2112 | (let* ((new (dired-string-replace-match | ||
| 2113 | regexp (file-name-nondirectory from) newname)) | ||
| 2114 | (to (and new ; nil means there was no match | ||
| 2115 | (expand-file-name new | ||
| 2116 | (file-name-directory from)))) | ||
| 2117 | (help-form rename-regexp-help-form)) | ||
| 2118 | (if to | ||
| 2119 | (and (dired-query 'rename-regexp-query | ||
| 2120 | operation-prompt | ||
| 2121 | (dired-make-relative from) | ||
| 2122 | (dired-make-relative to)) | ||
| 2123 | to) | ||
| 2124 | (dired-log "%s: %s did not match regexp %s\n" | ||
| 2125 | operation (file-name-nondirectory from) regexp)))))) | ||
| 2096 | rename-regexp-query) | 2126 | rename-regexp-query) |
| 2097 | (dired-create-files | 2127 | (dired-create-files |
| 2098 | file-creator operation fn-list regexp-name-constructor marker-char))) | 2128 | file-creator operation fn-list regexp-name-constructor marker-char))) |
| @@ -2130,7 +2160,7 @@ With a zero prefix arg, renaming by regexp affects the absolute file name. | |||
| 2130 | Normally, only the non-directory part of the file name is used and changed." | 2160 | Normally, only the non-directory part of the file name is used and changed." |
| 2131 | (interactive (dired-mark-read-regexp "Rename")) | 2161 | (interactive (dired-mark-read-regexp "Rename")) |
| 2132 | (dired-do-create-files-regexp | 2162 | (dired-do-create-files-regexp |
| 2133 | (function dired-rename-file) | 2163 | #'dired-rename-file |
| 2134 | "Rename" arg regexp newname whole-name dired-keep-marker-rename)) | 2164 | "Rename" arg regexp newname whole-name dired-keep-marker-rename)) |
| 2135 | 2165 | ||
| 2136 | ;;;###autoload | 2166 | ;;;###autoload |
| @@ -2140,7 +2170,7 @@ See function `dired-do-rename-regexp' for more info." | |||
| 2140 | (interactive (dired-mark-read-regexp "Copy")) | 2170 | (interactive (dired-mark-read-regexp "Copy")) |
| 2141 | (let ((dired-recursive-copies nil)) ; No recursive copies. | 2171 | (let ((dired-recursive-copies nil)) ; No recursive copies. |
| 2142 | (dired-do-create-files-regexp | 2172 | (dired-do-create-files-regexp |
| 2143 | (function dired-copy-file) | 2173 | #'dired-copy-file |
| 2144 | (if dired-copy-preserve-time "Copy [-p]" "Copy") | 2174 | (if dired-copy-preserve-time "Copy [-p]" "Copy") |
| 2145 | arg regexp newname whole-name dired-keep-marker-copy))) | 2175 | arg regexp newname whole-name dired-keep-marker-copy))) |
| 2146 | 2176 | ||
| @@ -2150,7 +2180,7 @@ See function `dired-do-rename-regexp' for more info." | |||
| 2150 | See function `dired-do-rename-regexp' for more info." | 2180 | See function `dired-do-rename-regexp' for more info." |
| 2151 | (interactive (dired-mark-read-regexp "HardLink")) | 2181 | (interactive (dired-mark-read-regexp "HardLink")) |
| 2152 | (dired-do-create-files-regexp | 2182 | (dired-do-create-files-regexp |
| 2153 | (function add-name-to-file) | 2183 | #'add-name-to-file |
| 2154 | "HardLink" arg regexp newname whole-name dired-keep-marker-hardlink)) | 2184 | "HardLink" arg regexp newname whole-name dired-keep-marker-hardlink)) |
| 2155 | 2185 | ||
| 2156 | ;;;###autoload | 2186 | ;;;###autoload |
| @@ -2159,7 +2189,7 @@ See function `dired-do-rename-regexp' for more info." | |||
| 2159 | See function `dired-do-rename-regexp' for more info." | 2189 | See function `dired-do-rename-regexp' for more info." |
| 2160 | (interactive (dired-mark-read-regexp "SymLink")) | 2190 | (interactive (dired-mark-read-regexp "SymLink")) |
| 2161 | (dired-do-create-files-regexp | 2191 | (dired-do-create-files-regexp |
| 2162 | (function make-symbolic-link) | 2192 | #'make-symbolic-link |
| 2163 | "SymLink" arg regexp newname whole-name dired-keep-marker-symlink)) | 2193 | "SymLink" arg regexp newname whole-name dired-keep-marker-symlink)) |
| 2164 | 2194 | ||
| 2165 | (defvar rename-non-directory-query) | 2195 | (defvar rename-non-directory-query) |
| @@ -2174,39 +2204,38 @@ See function `dired-do-rename-regexp' for more info." | |||
| 2174 | file-creator | 2204 | file-creator |
| 2175 | operation | 2205 | operation |
| 2176 | (dired-get-marked-files nil arg) | 2206 | (dired-get-marked-files nil arg) |
| 2177 | (function | 2207 | (lambda (from) |
| 2178 | (lambda (from) | 2208 | (let ((to (concat (file-name-directory from) |
| 2179 | (let ((to (concat (file-name-directory from) | 2209 | (funcall basename-constructor |
| 2180 | (funcall basename-constructor | 2210 | (file-name-nondirectory from))))) |
| 2181 | (file-name-nondirectory from))))) | 2211 | (and (let ((help-form (format-message "\ |
| 2182 | (and (let ((help-form (format-message "\ | ||
| 2183 | Type SPC or `y' to %s one file, DEL or `n' to skip to next, | 2212 | Type SPC or `y' to %s one file, DEL or `n' to skip to next, |
| 2184 | `!' to %s all remaining matches with no more questions." | 2213 | `!' to %s all remaining matches with no more questions." |
| 2185 | (downcase operation) | 2214 | (downcase operation) |
| 2186 | (downcase operation)))) | 2215 | (downcase operation)))) |
| 2187 | (dired-query 'rename-non-directory-query | 2216 | (dired-query 'rename-non-directory-query |
| 2188 | (concat operation " `%s' to `%s'") | 2217 | (concat operation " `%s' to `%s'") |
| 2189 | (dired-make-relative from) | 2218 | (dired-make-relative from) |
| 2190 | (dired-make-relative to))) | 2219 | (dired-make-relative to))) |
| 2191 | to)))) | 2220 | to))) |
| 2192 | dired-keep-marker-rename))) | 2221 | dired-keep-marker-rename))) |
| 2193 | 2222 | ||
| 2194 | (defun dired-rename-non-directory (basename-constructor operation arg) | 2223 | (defun dired-rename-non-directory (basename-constructor operation arg) |
| 2195 | (dired-create-files-non-directory | 2224 | (dired-create-files-non-directory |
| 2196 | (function dired-rename-file) | 2225 | #'dired-rename-file |
| 2197 | basename-constructor operation arg)) | 2226 | basename-constructor operation arg)) |
| 2198 | 2227 | ||
| 2199 | ;;;###autoload | 2228 | ;;;###autoload |
| 2200 | (defun dired-upcase (&optional arg) | 2229 | (defun dired-upcase (&optional arg) |
| 2201 | "Rename all marked (or next ARG) files to upper case." | 2230 | "Rename all marked (or next ARG) files to upper case." |
| 2202 | (interactive "P") | 2231 | (interactive "P") |
| 2203 | (dired-rename-non-directory (function upcase) "Rename upcase" arg)) | 2232 | (dired-rename-non-directory #'upcase "Rename upcase" arg)) |
| 2204 | 2233 | ||
| 2205 | ;;;###autoload | 2234 | ;;;###autoload |
| 2206 | (defun dired-downcase (&optional arg) | 2235 | (defun dired-downcase (&optional arg) |
| 2207 | "Rename all marked (or next ARG) files to lower case." | 2236 | "Rename all marked (or next ARG) files to lower case." |
| 2208 | (interactive "P") | 2237 | (interactive "P") |
| 2209 | (dired-rename-non-directory (function downcase) "Rename downcase" arg)) | 2238 | (dired-rename-non-directory #'downcase "Rename downcase" arg)) |
| 2210 | 2239 | ||
| 2211 | ;;;###end dired-re.el | 2240 | ;;;###end dired-re.el |
| 2212 | 2241 | ||
| @@ -2316,12 +2345,11 @@ This function takes some pains to conform to `ls -lR' output." | |||
| 2316 | (when real-switches | 2345 | (when real-switches |
| 2317 | (let (case-fold-search) | 2346 | (let (case-fold-search) |
| 2318 | (mapcar | 2347 | (mapcar |
| 2319 | (function | 2348 | (lambda (x) |
| 2320 | (lambda (x) | 2349 | (or (eq (null (string-match-p x real-switches)) |
| 2321 | (or (eq (null (string-match-p x real-switches)) | 2350 | (null (string-match-p x dired-actual-switches))) |
| 2322 | (null (string-match-p x dired-actual-switches))) | 2351 | (error |
| 2323 | (error | 2352 | "Can't have dirs with and without -%s switches together" x))) |
| 2324 | "Can't have dirs with and without -%s switches together" x)))) | ||
| 2325 | ;; all switches that make a difference to dired-get-filename: | 2353 | ;; all switches that make a difference to dired-get-filename: |
| 2326 | '("F" "b")))))) | 2354 | '("F" "b")))))) |
| 2327 | 2355 | ||
| @@ -2334,9 +2362,9 @@ This function takes some pains to conform to `ls -lR' output." | |||
| 2334 | ;; Keep the alist sorted on buffer position. | 2362 | ;; Keep the alist sorted on buffer position. |
| 2335 | (setq dired-subdir-alist | 2363 | (setq dired-subdir-alist |
| 2336 | (sort dired-subdir-alist | 2364 | (sort dired-subdir-alist |
| 2337 | (function (lambda (elt1 elt2) | 2365 | (lambda (elt1 elt2) |
| 2338 | (> (dired-get-subdir-min elt1) | 2366 | (> (dired-get-subdir-min elt1) |
| 2339 | (dired-get-subdir-min elt2))))))) | 2367 | (dired-get-subdir-min elt2)))))) |
| 2340 | 2368 | ||
| 2341 | (defun dired-kill-tree (dirname &optional remember-marks kill-root) | 2369 | (defun dired-kill-tree (dirname &optional remember-marks kill-root) |
| 2342 | "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. | 2370 | "Kill all proper subdirs of DIRNAME, excluding DIRNAME itself. |
diff --git a/lisp/dired.el b/lisp/dired.el index 909735a3b54..0c1f3e4af64 100644 --- a/lisp/dired.el +++ b/lisp/dired.el | |||
| @@ -335,9 +335,8 @@ The directory name must be absolute, but need not be fully expanded.") | |||
| 335 | (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d[^:]")) | 335 | (defvar dired-re-dir (concat dired-re-maybe-mark dired-re-inode-size "d[^:]")) |
| 336 | (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l[^:]")) | 336 | (defvar dired-re-sym (concat dired-re-maybe-mark dired-re-inode-size "l[^:]")) |
| 337 | (defvar dired-re-exe;; match ls permission string of an executable file | 337 | (defvar dired-re-exe;; match ls permission string of an executable file |
| 338 | (mapconcat (function | 338 | (mapconcat (lambda (x) |
| 339 | (lambda (x) | 339 | (concat dired-re-maybe-mark dired-re-inode-size x)) |
| 340 | (concat dired-re-maybe-mark dired-re-inode-size x))) | ||
| 341 | '("-[-r][-w][xs][-r][-w].[-r][-w]." | 340 | '("-[-r][-w][xs][-r][-w].[-r][-w]." |
| 342 | "-[-r][-w].[-r][-w][xs][-r][-w]." | 341 | "-[-r][-w].[-r][-w][xs][-r][-w]." |
| 343 | "-[-r][-w].[-r][-w].[-r][-w][xst]") | 342 | "-[-r][-w].[-r][-w].[-r][-w][xst]") |
| @@ -607,9 +606,9 @@ marked file, return (t FILENAME) instead of (FILENAME)." | |||
| 607 | (progn ;; no save-excursion, want to move point. | 606 | (progn ;; no save-excursion, want to move point. |
| 608 | (dired-repeat-over-lines | 607 | (dired-repeat-over-lines |
| 609 | ,arg | 608 | ,arg |
| 610 | (function (lambda () | 609 | (lambda () |
| 611 | (if ,show-progress (sit-for 0)) | 610 | (if ,show-progress (sit-for 0)) |
| 612 | (setq results (cons ,body results))))) | 611 | (setq results (cons ,body results)))) |
| 613 | (if (< ,arg 0) | 612 | (if (< ,arg 0) |
| 614 | (nreverse results) | 613 | (nreverse results) |
| 615 | results)) | 614 | results)) |
| @@ -1995,8 +1994,8 @@ Keybindings: | |||
| 1995 | ;; Ignore dired-hide-details-* value of invisible text property by default. | 1994 | ;; Ignore dired-hide-details-* value of invisible text property by default. |
| 1996 | (when (eq buffer-invisibility-spec t) | 1995 | (when (eq buffer-invisibility-spec t) |
| 1997 | (setq buffer-invisibility-spec (list t))) | 1996 | (setq buffer-invisibility-spec (list t))) |
| 1998 | (setq-local revert-buffer-function (function dired-revert)) | 1997 | (setq-local revert-buffer-function #'dired-revert) |
| 1999 | (setq-local buffer-stale-function (function dired-buffer-stale-p)) | 1998 | (setq-local buffer-stale-function #'dired-buffer-stale-p) |
| 2000 | (setq-local page-delimiter "\n\n") | 1999 | (setq-local page-delimiter "\n\n") |
| 2001 | (setq-local dired-directory (or dirname default-directory)) | 2000 | (setq-local dired-directory (or dirname default-directory)) |
| 2002 | ;; list-buffers uses this to display the dir being edited in this buffer. | 2001 | ;; list-buffers uses this to display the dir being edited in this buffer. |
| @@ -2469,7 +2468,7 @@ You can then feed the file name(s) to other commands with \\[yank]." | |||
| 2469 | (interactive "P") | 2468 | (interactive "P") |
| 2470 | (let ((string | 2469 | (let ((string |
| 2471 | (or (dired-get-subdir) | 2470 | (or (dired-get-subdir) |
| 2472 | (mapconcat (function identity) | 2471 | (mapconcat #'identity |
| 2473 | (if arg | 2472 | (if arg |
| 2474 | (cond ((zerop (prefix-numeric-value arg)) | 2473 | (cond ((zerop (prefix-numeric-value arg)) |
| 2475 | (dired-get-marked-files)) | 2474 | (dired-get-marked-files)) |
| @@ -2971,12 +2970,12 @@ non-empty directories is allowed." | |||
| 2971 | ;; lines still to be changed, so the (point) values in L stay valid. | 2970 | ;; lines still to be changed, so the (point) values in L stay valid. |
| 2972 | ;; Also, for subdirs in natural order, a subdir's files are deleted | 2971 | ;; Also, for subdirs in natural order, a subdir's files are deleted |
| 2973 | ;; before the subdir itself - the other way around would not work. | 2972 | ;; before the subdir itself - the other way around would not work. |
| 2974 | (let* ((files (mapcar (function car) l)) | 2973 | (let* ((files (mapcar #'car l)) |
| 2975 | (count (length l)) | 2974 | (count (length l)) |
| 2976 | (succ 0) | 2975 | (succ 0) |
| 2977 | (trashing (and trash delete-by-moving-to-trash))) | 2976 | (trashing (and trash delete-by-moving-to-trash))) |
| 2978 | ;; canonicalize file list for pop up | 2977 | ;; canonicalize file list for pop up |
| 2979 | (setq files (nreverse (mapcar (function dired-make-relative) files))) | 2978 | (setq files (nreverse (mapcar #'dired-make-relative files))) |
| 2980 | (if (dired-mark-pop-up | 2979 | (if (dired-mark-pop-up |
| 2981 | " *Deletions*" 'delete files dired-deletion-confirmer | 2980 | " *Deletions*" 'delete files dired-deletion-confirmer |
| 2982 | (format "%s %s " | 2981 | (format "%s %s " |
| @@ -2999,7 +2998,7 @@ non-empty directories is allowed." | |||
| 2999 | (progress-reporter-update progress-reporter succ) | 2998 | (progress-reporter-update progress-reporter succ) |
| 3000 | (dired-fun-in-all-buffers | 2999 | (dired-fun-in-all-buffers |
| 3001 | (file-name-directory fn) (file-name-nondirectory fn) | 3000 | (file-name-directory fn) (file-name-nondirectory fn) |
| 3002 | (function dired-delete-entry) fn)) | 3001 | #'dired-delete-entry fn)) |
| 3003 | (error ;; catch errors from failed deletions | 3002 | (error ;; catch errors from failed deletions |
| 3004 | (dired-log "%s\n" err) | 3003 | (dired-log "%s\n" err) |
| 3005 | (setq failures (cons (car (car l)) failures))))) | 3004 | (setq failures (cons (car (car l)) failures))))) |
| @@ -3293,7 +3292,7 @@ this subdir." | |||
| 3293 | (let ((inhibit-read-only t)) | 3292 | (let ((inhibit-read-only t)) |
| 3294 | (dired-repeat-over-lines | 3293 | (dired-repeat-over-lines |
| 3295 | (prefix-numeric-value arg) | 3294 | (prefix-numeric-value arg) |
| 3296 | (function (lambda () (delete-char 1) (insert dired-marker-char)))))))) | 3295 | (lambda () (delete-char 1) (insert dired-marker-char))))))) |
| 3297 | 3296 | ||
| 3298 | (defun dired-unmark (arg &optional interactive) | 3297 | (defun dired-unmark (arg &optional interactive) |
| 3299 | "Unmark the file at point in the Dired buffer. | 3298 | "Unmark the file at point in the Dired buffer. |
| @@ -3928,7 +3927,7 @@ Ask means pop up a menu for the user to select one of copy, move or link." | |||
| 3928 | (cdr | 3927 | (cdr |
| 3929 | (nreverse | 3928 | (nreverse |
| 3930 | (mapcar | 3929 | (mapcar |
| 3931 | (function (lambda (f) (desktop-file-name (car f) dirname))) | 3930 | (lambda (f) (desktop-file-name (car f) dirname)) |
| 3932 | dired-subdir-alist))))) | 3931 | dired-subdir-alist))))) |
| 3933 | 3932 | ||
| 3934 | (defun dired-restore-desktop-buffer (_file-name | 3933 | (defun dired-restore-desktop-buffer (_file-name |
diff --git a/lisp/electric.el b/lisp/electric.el index 4078ef8193e..1564df5949c 100644 --- a/lisp/electric.el +++ b/lisp/electric.el | |||
| @@ -443,11 +443,24 @@ quote, left double quote, and right double quote, respectively." | |||
| 443 | :version "25.1" | 443 | :version "25.1" |
| 444 | :type 'boolean :safe 'booleanp :group 'electricity) | 444 | :type 'boolean :safe 'booleanp :group 'electricity) |
| 445 | 445 | ||
| 446 | (defcustom electric-quote-context-sensitive nil | ||
| 447 | "Non-nil means to replace \\=' with an electric quote depending on context. | ||
| 448 | If `electric-quote-context-sensitive' is non-nil, Emacs replaces | ||
| 449 | \\=' and \\='\\=' with an opening quote after a line break, | ||
| 450 | whitespace, opening parenthesis, or quote and leaves \\=` alone." | ||
| 451 | :version "26.1" | ||
| 452 | :type 'boolean :safe #'booleanp :group 'electricity) | ||
| 453 | |||
| 454 | (defvar electric-quote-code-faces () | ||
| 455 | "List of faces to treat as inline code in `text-mode'.") | ||
| 456 | |||
| 446 | (defun electric-quote-post-self-insert-function () | 457 | (defun electric-quote-post-self-insert-function () |
| 447 | "Function that `electric-quote-mode' adds to `post-self-insert-hook'. | 458 | "Function that `electric-quote-mode' adds to `post-self-insert-hook'. |
| 448 | This requotes when a quoting key is typed." | 459 | This requotes when a quoting key is typed." |
| 449 | (when (and electric-quote-mode | 460 | (when (and electric-quote-mode |
| 450 | (memq last-command-event '(?\' ?\`))) | 461 | (or (eq last-command-event ?\') |
| 462 | (and (not electric-quote-context-sensitive) | ||
| 463 | (eq last-command-event ?\`)))) | ||
| 451 | (let ((start | 464 | (let ((start |
| 452 | (if (and comment-start comment-use-syntax) | 465 | (if (and comment-start comment-use-syntax) |
| 453 | (when (or electric-quote-comment electric-quote-string) | 466 | (when (or electric-quote-comment electric-quote-string) |
| @@ -462,30 +475,45 @@ This requotes when a quoting key is typed." | |||
| 462 | (syntax-ppss (1- (point))))))))) | 475 | (syntax-ppss (1- (point))))))))) |
| 463 | (and electric-quote-paragraph | 476 | (and electric-quote-paragraph |
| 464 | (derived-mode-p 'text-mode) | 477 | (derived-mode-p 'text-mode) |
| 478 | ;; FIXME: There should be a ‘cl-disjoint’ function. | ||
| 479 | (null (cl-intersection (face-at-point nil 'multiple) | ||
| 480 | electric-quote-code-faces | ||
| 481 | :test #'eq)) | ||
| 482 | ;; FIXME: Why is the next form there? It’s never | ||
| 483 | ;; nil. | ||
| 465 | (or (eq last-command-event ?\`) | 484 | (or (eq last-command-event ?\`) |
| 466 | (save-excursion (backward-paragraph) (point))))))) | 485 | (save-excursion (backward-paragraph) (point))))))) |
| 467 | (pcase electric-quote-chars | 486 | (pcase electric-quote-chars |
| 468 | (`(,q< ,q> ,q<< ,q>>) | 487 | (`(,q< ,q> ,q<< ,q>>) |
| 469 | (when start | 488 | (when start |
| 470 | (save-excursion | 489 | (save-excursion |
| 471 | (if (eq last-command-event ?\`) | 490 | (let ((backtick ?\`)) |
| 472 | (cond ((search-backward (string q< ?`) (- (point) 2) t) | 491 | (if (or (eq last-command-event ?\`) |
| 473 | (replace-match (string q<<)) | 492 | (and electric-quote-context-sensitive |
| 474 | (when (and electric-pair-mode | 493 | (save-excursion |
| 475 | (eq (cdr-safe | 494 | (backward-char) |
| 476 | (assq q< electric-pair-text-pairs)) | 495 | (or (bobp) (bolp) |
| 477 | (char-after))) | 496 | (memq (char-before) (list q< q<<)) |
| 478 | (delete-char 1)) | 497 | (memq (char-syntax (char-before)) |
| 479 | (setq last-command-event q<<)) | 498 | '(?\s ?\()))) |
| 480 | ((search-backward "`" (1- (point)) t) | 499 | (setq backtick ?\'))) |
| 481 | (replace-match (string q<)) | 500 | (cond ((search-backward (string q< backtick) (- (point) 2) t) |
| 482 | (setq last-command-event q<))) | 501 | (replace-match (string q<<)) |
| 483 | (cond ((search-backward (string q> ?') (- (point) 2) t) | 502 | (when (and electric-pair-mode |
| 484 | (replace-match (string q>>)) | 503 | (eq (cdr-safe |
| 485 | (setq last-command-event q>>)) | 504 | (assq q< electric-pair-text-pairs)) |
| 486 | ((search-backward "'" (1- (point)) t) | 505 | (char-after))) |
| 487 | (replace-match (string q>)) | 506 | (delete-char 1)) |
| 488 | (setq last-command-event q>))))))))))) | 507 | (setq last-command-event q<<)) |
| 508 | ((search-backward (string backtick) (1- (point)) t) | ||
| 509 | (replace-match (string q<)) | ||
| 510 | (setq last-command-event q<))) | ||
| 511 | (cond ((search-backward (string q> ?') (- (point) 2) t) | ||
| 512 | (replace-match (string q>>)) | ||
| 513 | (setq last-command-event q>>)) | ||
| 514 | ((search-backward "'" (1- (point)) t) | ||
| 515 | (replace-match (string q>)) | ||
| 516 | (setq last-command-event q>)))))))))))) | ||
| 489 | 517 | ||
| 490 | (put 'electric-quote-post-self-insert-function 'priority 10) | 518 | (put 'electric-quote-post-self-insert-function 'priority 10) |
| 491 | 519 | ||
diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 3852ceb6c31..99df209d1a2 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el | |||
| @@ -437,22 +437,38 @@ as an integer unless JUNK-ALLOWED is non-nil." | |||
| 437 | 437 | ||
| 438 | ;; Random numbers. | 438 | ;; Random numbers. |
| 439 | 439 | ||
| 440 | (defun cl--random-time () | ||
| 441 | (let* ((time (copy-sequence (current-time-string))) (i (length time)) (v 0)) | ||
| 442 | (while (>= (cl-decf i) 0) (setq v (+ (* v 3) (aref time i)))) | ||
| 443 | v)) | ||
| 444 | |||
| 445 | ;;;###autoload (autoload 'cl-random-state-p "cl-extra") | ||
| 446 | (cl-defstruct (cl--random-state | ||
| 447 | (:copier nil) | ||
| 448 | (:predicate cl-random-state-p) | ||
| 449 | (:constructor nil) | ||
| 450 | (:constructor cl--make-random-state (vec))) | ||
| 451 | (i -1) (j 30) vec) | ||
| 452 | |||
| 453 | (defvar cl--random-state (cl--make-random-state (cl--random-time))) | ||
| 454 | |||
| 440 | ;;;###autoload | 455 | ;;;###autoload |
| 441 | (defun cl-random (lim &optional state) | 456 | (defun cl-random (lim &optional state) |
| 442 | "Return a random nonnegative number less than LIM, an integer or float. | 457 | "Return a random nonnegative number less than LIM, an integer or float. |
| 443 | Optional second arg STATE is a random-state object." | 458 | Optional second arg STATE is a random-state object." |
| 444 | (or state (setq state cl--random-state)) | 459 | (or state (setq state cl--random-state)) |
| 445 | ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. | 460 | ;; Inspired by "ran3" from Numerical Recipes. Additive congruential method. |
| 446 | (let ((vec (aref state 3))) | 461 | (let ((vec (cl--random-state-vec state))) |
| 447 | (if (integerp vec) | 462 | (if (integerp vec) |
| 448 | (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1)) | 463 | (let ((i 0) (j (- 1357335 (abs (% vec 1357333)))) (k 1)) |
| 449 | (aset state 3 (setq vec (make-vector 55 nil))) | 464 | (setf (cl--random-state-vec state) |
| 465 | (setq vec (make-vector 55 nil))) | ||
| 450 | (aset vec 0 j) | 466 | (aset vec 0 j) |
| 451 | (while (> (setq i (% (+ i 21) 55)) 0) | 467 | (while (> (setq i (% (+ i 21) 55)) 0) |
| 452 | (aset vec i (setq j (prog1 k (setq k (- j k)))))) | 468 | (aset vec i (setq j (prog1 k (setq k (- j k)))))) |
| 453 | (while (< (setq i (1+ i)) 200) (cl-random 2 state)))) | 469 | (while (< (setq i (1+ i)) 200) (cl-random 2 state)))) |
| 454 | (let* ((i (aset state 1 (% (1+ (aref state 1)) 55))) | 470 | (let* ((i (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-i state))) |
| 455 | (j (aset state 2 (% (1+ (aref state 2)) 55))) | 471 | (j (cl-callf (lambda (x) (% (1+ x) 55)) (cl--random-state-j state))) |
| 456 | (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) | 472 | (n (logand 8388607 (aset vec i (- (aref vec i) (aref vec j)))))) |
| 457 | (if (integerp lim) | 473 | (if (integerp lim) |
| 458 | (if (<= lim 512) (% n lim) | 474 | (if (<= lim 512) (% n lim) |
| @@ -466,17 +482,10 @@ Optional second arg STATE is a random-state object." | |||
| 466 | (defun cl-make-random-state (&optional state) | 482 | (defun cl-make-random-state (&optional state) |
| 467 | "Return a copy of random-state STATE, or of the internal state if omitted. | 483 | "Return a copy of random-state STATE, or of the internal state if omitted. |
| 468 | If STATE is t, return a new state object seeded from the time of day." | 484 | If STATE is t, return a new state object seeded from the time of day." |
| 469 | (cond ((null state) (cl-make-random-state cl--random-state)) | 485 | (unless state (setq state cl--random-state)) |
| 470 | ((vectorp state) (copy-tree state t)) | 486 | (if (cl-random-state-p state) |
| 471 | ((integerp state) (vector 'cl--random-state-tag -1 30 state)) | 487 | (copy-tree state t) |
| 472 | (t (cl-make-random-state (cl--random-time))))) | 488 | (cl--make-random-state (if (integerp state) state (cl--random-time))))) |
| 473 | |||
| 474 | ;;;###autoload | ||
| 475 | (defun cl-random-state-p (object) | ||
| 476 | "Return t if OBJECT is a random-state object." | ||
| 477 | (and (vectorp object) (= (length object) 4) | ||
| 478 | (eq (aref object 0) 'cl--random-state-tag))) | ||
| 479 | |||
| 480 | 489 | ||
| 481 | ;; Implementation limits. | 490 | ;; Implementation limits. |
| 482 | 491 | ||
diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el index 89a71d1b6c5..e9ca0412848 100644 --- a/lisp/emacs-lisp/cl-print.el +++ b/lisp/emacs-lisp/cl-print.el | |||
| @@ -90,7 +90,7 @@ call other entry points instead, such as `cl-prin1'." | |||
| 90 | - `disassemble' to print the disassembly of the code. | 90 | - `disassemble' to print the disassembly of the code. |
| 91 | - nil to skip printing any details about the code.") | 91 | - nil to skip printing any details about the code.") |
| 92 | 92 | ||
| 93 | (defvar cl-print-compiled-button nil | 93 | (defvar cl-print-compiled-button t |
| 94 | "Control how to print byte-compiled functions into buffers. | 94 | "Control how to print byte-compiled functions into buffers. |
| 95 | When the stream is a buffer, make the bytecode part of the output | 95 | When the stream is a buffer, make the bytecode part of the output |
| 96 | into a button whose action shows the function's disassembly.") | 96 | into a button whose action shows the function's disassembly.") |
| @@ -105,10 +105,11 @@ into a button whose action shows the function's disassembly.") | |||
| 105 | (if args | 105 | (if args |
| 106 | (prin1 args stream) | 106 | (prin1 args stream) |
| 107 | (princ "()" stream))) | 107 | (princ "()" stream))) |
| 108 | (let ((doc (documentation object 'raw))) | 108 | (pcase (help-split-fundoc (documentation object 'raw) object) |
| 109 | (when doc | 109 | ;; Drop args which `help-function-arglist' already printed. |
| 110 | (princ " " stream) | 110 | (`(,_usage . ,(and doc (guard (stringp doc)))) |
| 111 | (prin1 doc stream))) | 111 | (princ " " stream) |
| 112 | (prin1 doc stream))) | ||
| 112 | (let ((inter (interactive-form object))) | 113 | (let ((inter (interactive-form object))) |
| 113 | (when inter | 114 | (when inter |
| 114 | (princ " " stream) | 115 | (princ " " stream) |
diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index 83456fc31a2..2b8782590c4 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el | |||
| @@ -49,6 +49,12 @@ the middle is discarded, and just the beginning and end are displayed." | |||
| 49 | :group 'debugger | 49 | :group 'debugger |
| 50 | :version "21.1") | 50 | :version "21.1") |
| 51 | 51 | ||
| 52 | (defcustom debugger-print-function #'cl-prin1 | ||
| 53 | "Function used to print values in the debugger backtraces." | ||
| 54 | :type 'function | ||
| 55 | :options '(cl-prin1 prin1) | ||
| 56 | :version "26.1") | ||
| 57 | |||
| 52 | (defcustom debugger-bury-or-kill 'bury | 58 | (defcustom debugger-bury-or-kill 'bury |
| 53 | "What to do with the debugger buffer when exiting `debug'. | 59 | "What to do with the debugger buffer when exiting `debug'. |
| 54 | The value affects the behavior of operations on any window | 60 | The value affects the behavior of operations on any window |
| @@ -264,6 +270,40 @@ first will be printed into the backtrace buffer." | |||
| 264 | (setq debug-on-next-call debugger-step-after-exit) | 270 | (setq debug-on-next-call debugger-step-after-exit) |
| 265 | debugger-value))) | 271 | debugger-value))) |
| 266 | 272 | ||
| 273 | |||
| 274 | (defun debugger-insert-backtrace (frames do-xrefs) | ||
| 275 | "Format and insert the backtrace FRAMES at point. | ||
| 276 | Make functions into cross-reference buttons if DO-XREFS is non-nil." | ||
| 277 | (let ((standard-output (current-buffer)) | ||
| 278 | (eval-buffers eval-buffer-list)) | ||
| 279 | (require 'help-mode) ; Define `help-function-def' button type. | ||
| 280 | (pcase-dolist (`(,evald ,fun ,args ,flags) frames) | ||
| 281 | (insert (if (plist-get flags :debug-on-exit) | ||
| 282 | "* " " ")) | ||
| 283 | (let ((fun-file (and do-xrefs (symbol-file fun 'defun))) | ||
| 284 | (fun-pt (point))) | ||
| 285 | (cond | ||
| 286 | ((and evald (not debugger-stack-frame-as-list)) | ||
| 287 | (funcall debugger-print-function fun) | ||
| 288 | (if args (funcall debugger-print-function args) (princ "()"))) | ||
| 289 | (t | ||
| 290 | (funcall debugger-print-function (cons fun args)) | ||
| 291 | (cl-incf fun-pt))) | ||
| 292 | (when fun-file | ||
| 293 | (make-text-button fun-pt (+ fun-pt (length (symbol-name fun))) | ||
| 294 | :type 'help-function-def | ||
| 295 | 'help-args (list fun fun-file)))) | ||
| 296 | ;; After any frame that uses eval-buffer, insert a line that | ||
| 297 | ;; states the buffer position it's reading at. | ||
| 298 | (when (and eval-buffers (memq fun '(eval-buffer eval-region))) | ||
| 299 | (insert (format " ; Reading at buffer position %d" | ||
| 300 | ;; This will get the wrong result if there are | ||
| 301 | ;; two nested eval-region calls for the same | ||
| 302 | ;; buffer. That's not a very useful case. | ||
| 303 | (with-current-buffer (pop eval-buffers) | ||
| 304 | (point))))) | ||
| 305 | (insert "\n")))) | ||
| 306 | |||
| 267 | (defun debugger-setup-buffer (args) | 307 | (defun debugger-setup-buffer (args) |
| 268 | "Initialize the `*Backtrace*' buffer for entry to the debugger. | 308 | "Initialize the `*Backtrace*' buffer for entry to the debugger. |
| 269 | That buffer should be current already." | 309 | That buffer should be current already." |
| @@ -271,27 +311,20 @@ That buffer should be current already." | |||
| 271 | (erase-buffer) | 311 | (erase-buffer) |
| 272 | (set-buffer-multibyte t) ;Why was it nil ? -stef | 312 | (set-buffer-multibyte t) ;Why was it nil ? -stef |
| 273 | (setq buffer-undo-list t) | 313 | (setq buffer-undo-list t) |
| 274 | (let ((standard-output (current-buffer)) | ||
| 275 | (print-escape-newlines t) | ||
| 276 | (print-level 8) | ||
| 277 | (print-length 50)) | ||
| 278 | ;; FIXME the debugger could pass a custom callback to mapbacktrace | ||
| 279 | ;; instead of manipulating printed results. | ||
| 280 | (mapbacktrace #'backtrace--print-frame 'debug)) | ||
| 281 | (goto-char (point-min)) | ||
| 282 | (delete-region (point) | ||
| 283 | (progn | ||
| 284 | (forward-line (if (eq (car args) 'debug) | ||
| 285 | ;; Remove debug--implement-debug-on-entry | ||
| 286 | ;; and the advice's `apply' frame. | ||
| 287 | 3 | ||
| 288 | 1)) | ||
| 289 | (point))) | ||
| 290 | (insert "Debugger entered") | 314 | (insert "Debugger entered") |
| 291 | ;; lambda is for debug-on-call when a function call is next. | 315 | (let ((frames (nthcdr |
| 292 | ;; debug is for debug-on-entry function called. | 316 | ;; Remove debug--implement-debug-on-entry and the |
| 293 | (let ((pos (point))) | 317 | ;; advice's `apply' frame. |
| 318 | (if (eq (car args) 'debug) 3 1) | ||
| 319 | (backtrace-frames 'debug))) | ||
| 320 | (print-escape-newlines t) | ||
| 321 | (print-escape-control-characters t) | ||
| 322 | (print-level 8) | ||
| 323 | (print-length 50) | ||
| 324 | (pos (point))) | ||
| 294 | (pcase (car args) | 325 | (pcase (car args) |
| 326 | ;; lambda is for debug-on-call when a function call is next. | ||
| 327 | ;; debug is for debug-on-entry function called. | ||
| 295 | ((or `lambda `debug) | 328 | ((or `lambda `debug) |
| 296 | (insert "--entering a function:\n") | 329 | (insert "--entering a function:\n") |
| 297 | (setq pos (1- (point)))) | 330 | (setq pos (1- (point)))) |
| @@ -300,11 +333,9 @@ That buffer should be current already." | |||
| 300 | (insert "--returning value: ") | 333 | (insert "--returning value: ") |
| 301 | (setq pos (point)) | 334 | (setq pos (point)) |
| 302 | (setq debugger-value (nth 1 args)) | 335 | (setq debugger-value (nth 1 args)) |
| 303 | (prin1 debugger-value (current-buffer)) | 336 | (funcall debugger-print-function debugger-value (current-buffer)) |
| 304 | (insert ?\n) | 337 | (setf (cl-getf (nth 3 (car frames)) :debug-on-exit) nil) |
| 305 | (delete-char 1) | 338 | (insert ?\n)) |
| 306 | (insert ? ) | ||
| 307 | (beginning-of-line)) | ||
| 308 | ;; Watchpoint triggered. | 339 | ;; Watchpoint triggered. |
| 309 | ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) | 340 | ((and `watchpoint (let `(,symbol ,newval . ,details) (cdr args))) |
| 310 | (insert | 341 | (insert |
| @@ -327,7 +358,7 @@ That buffer should be current already." | |||
| 327 | (`error | 358 | (`error |
| 328 | (insert "--Lisp error: ") | 359 | (insert "--Lisp error: ") |
| 329 | (setq pos (point)) | 360 | (setq pos (point)) |
| 330 | (prin1 (nth 1 args) (current-buffer)) | 361 | (funcall debugger-print-function (nth 1 args) (current-buffer)) |
| 331 | (insert ?\n)) | 362 | (insert ?\n)) |
| 332 | ;; debug-on-call, when the next thing is an eval. | 363 | ;; debug-on-call, when the next thing is an eval. |
| 333 | (`t | 364 | (`t |
| @@ -337,98 +368,15 @@ That buffer should be current already." | |||
| 337 | (_ | 368 | (_ |
| 338 | (insert ": ") | 369 | (insert ": ") |
| 339 | (setq pos (point)) | 370 | (setq pos (point)) |
| 340 | (prin1 (if (eq (car args) 'nil) | 371 | (funcall debugger-print-function |
| 341 | (cdr args) args) | 372 | (if (eq (car args) 'nil) |
| 342 | (current-buffer)) | 373 | (cdr args) args) |
| 374 | (current-buffer)) | ||
| 343 | (insert ?\n))) | 375 | (insert ?\n))) |
| 376 | (debugger-insert-backtrace frames t) | ||
| 344 | ;; Place point on "stack frame 0" (bug#15101). | 377 | ;; Place point on "stack frame 0" (bug#15101). |
| 345 | (goto-char pos)) | 378 | (goto-char pos))) |
| 346 | ;; After any frame that uses eval-buffer, | 379 | |
| 347 | ;; insert a line that states the buffer position it's reading at. | ||
| 348 | (save-excursion | ||
| 349 | (let ((tem eval-buffer-list)) | ||
| 350 | (while (and tem | ||
| 351 | (re-search-forward "^ eval-\\(buffer\\|region\\)(" nil t)) | ||
| 352 | (end-of-line) | ||
| 353 | (insert (format " ; Reading at buffer position %d" | ||
| 354 | ;; This will get the wrong result | ||
| 355 | ;; if there are two nested eval-region calls | ||
| 356 | ;; for the same buffer. That's not a very useful case. | ||
| 357 | (with-current-buffer (car tem) | ||
| 358 | (point)))) | ||
| 359 | (pop tem)))) | ||
| 360 | (debugger-make-xrefs)) | ||
| 361 | |||
| 362 | (defun debugger-make-xrefs (&optional buffer) | ||
| 363 | "Attach cross-references to function names in the `*Backtrace*' buffer." | ||
| 364 | (interactive "b") | ||
| 365 | (with-current-buffer (or buffer (current-buffer)) | ||
| 366 | (save-excursion | ||
| 367 | (setq buffer (current-buffer)) | ||
| 368 | (let ((inhibit-read-only t) | ||
| 369 | (old-end (point-min)) (new-end (point-min))) | ||
| 370 | ;; If we saved an old backtrace, find the common part | ||
| 371 | ;; between the new and the old. | ||
| 372 | ;; Compare line by line, starting from the end, | ||
| 373 | ;; because that's the part that is likely to be unchanged. | ||
| 374 | (if debugger-previous-backtrace | ||
| 375 | (let (old-start new-start (all-match t)) | ||
| 376 | (goto-char (point-max)) | ||
| 377 | (with-temp-buffer | ||
| 378 | (insert debugger-previous-backtrace) | ||
| 379 | (while (and all-match (not (bobp))) | ||
| 380 | (setq old-end (point)) | ||
| 381 | (forward-line -1) | ||
| 382 | (setq old-start (point)) | ||
| 383 | (with-current-buffer buffer | ||
| 384 | (setq new-end (point)) | ||
| 385 | (forward-line -1) | ||
| 386 | (setq new-start (point))) | ||
| 387 | (if (not (zerop | ||
| 388 | (let ((case-fold-search nil)) | ||
| 389 | (compare-buffer-substrings | ||
| 390 | (current-buffer) old-start old-end | ||
| 391 | buffer new-start new-end)))) | ||
| 392 | (setq all-match nil)))) | ||
| 393 | ;; Now new-end is the position of the start of the | ||
| 394 | ;; unchanged part in the current buffer, and old-end is | ||
| 395 | ;; the position of that same text in the saved old | ||
| 396 | ;; backtrace. But we must subtract (point-min) since strings are | ||
| 397 | ;; indexed in origin 0. | ||
| 398 | |||
| 399 | ;; Replace the unchanged part of the backtrace | ||
| 400 | ;; with the text from debugger-previous-backtrace, | ||
| 401 | ;; since that already has the proper xrefs. | ||
| 402 | ;; With this optimization, we only need to scan | ||
| 403 | ;; the changed part of the backtrace. | ||
| 404 | (delete-region new-end (point-max)) | ||
| 405 | (goto-char (point-max)) | ||
| 406 | (insert (substring debugger-previous-backtrace | ||
| 407 | (- old-end (point-min)))) | ||
| 408 | ;; Make the unchanged part of the backtrace inaccessible | ||
| 409 | ;; so it won't be scanned. | ||
| 410 | (narrow-to-region (point-min) new-end))) | ||
| 411 | |||
| 412 | ;; Scan the new part of the backtrace, inserting xrefs. | ||
| 413 | (goto-char (point-min)) | ||
| 414 | (while (progn | ||
| 415 | (goto-char (+ (point) 2)) | ||
| 416 | (skip-syntax-forward "^w_") | ||
| 417 | (not (eobp))) | ||
| 418 | (let* ((beg (point)) | ||
| 419 | (end (progn (skip-syntax-forward "w_") (point))) | ||
| 420 | (sym (intern-soft (buffer-substring-no-properties | ||
| 421 | beg end))) | ||
| 422 | (file (and sym (symbol-file sym 'defun)))) | ||
| 423 | (when file | ||
| 424 | (goto-char beg) | ||
| 425 | ;; help-xref-button needs to operate on something matched | ||
| 426 | ;; by a regexp, so set that up for it. | ||
| 427 | (re-search-forward "\\(\\sw\\|\\s_\\)+") | ||
| 428 | (help-xref-button 0 'help-function-def sym file))) | ||
| 429 | (forward-line 1)) | ||
| 430 | (widen)) | ||
| 431 | (setq debugger-previous-backtrace (buffer-string))))) | ||
| 432 | 380 | ||
| 433 | (defun debugger-step-through () | 381 | (defun debugger-step-through () |
| 434 | "Proceed, stepping through subexpressions of this expression. | 382 | "Proceed, stepping through subexpressions of this expression. |
| @@ -866,9 +814,13 @@ To specify a nil argument interactively, exit with an empty minibuffer." | |||
| 866 | 'type 'help-function | 814 | 'type 'help-function |
| 867 | 'help-args (list fun)) | 815 | 'help-args (list fun)) |
| 868 | (terpri)) | 816 | (terpri)) |
| 869 | (terpri) | 817 | ;; Now that debug--function-list uses advice-member-p, its |
| 870 | (princ "Note: if you have redefined a function, then it may no longer\n") | 818 | ;; output should be reliable (except for bugs and the exceptional |
| 871 | (princ "be set to debug on entry, even if it is in the list.")))))) | 819 | ;; case where some other advice ends up overriding ours). |
| 820 | ;;(terpri) | ||
| 821 | ;;(princ "Note: if you have redefined a function, then it may no longer\n") | ||
| 822 | ;;(princ "be set to debug on entry, even if it is in the list.") | ||
| 823 | ))))) | ||
| 872 | 824 | ||
| 873 | (defun debug--implement-debug-watch (symbol newval op where) | 825 | (defun debug--implement-debug-watch (symbol newval op where) |
| 874 | "Conditionally call the debugger. | 826 | "Conditionally call the debugger. |
diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index dfe1c06bfaf..9d618e1dc81 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el | |||
| @@ -84,7 +84,7 @@ Currently under control of this var: | |||
| 84 | (progn | 84 | (progn |
| 85 | ;; Arrange for field access not to bother checking if the access is indeed | 85 | ;; Arrange for field access not to bother checking if the access is indeed |
| 86 | ;; made to an eieio--class object. | 86 | ;; made to an eieio--class object. |
| 87 | (cl-declaim (optimize (safety 0))) | 87 | (eval-when-compile (cl-declaim (optimize (safety 0)))) |
| 88 | 88 | ||
| 89 | (cl-defstruct (eieio--class | 89 | (cl-defstruct (eieio--class |
| 90 | (:constructor nil) | 90 | (:constructor nil) |
| @@ -103,8 +103,12 @@ Currently under control of this var: | |||
| 103 | options ;; storage location of tagged class option | 103 | options ;; storage location of tagged class option |
| 104 | ; Stored outright without modifications or stripping | 104 | ; Stored outright without modifications or stripping |
| 105 | ) | 105 | ) |
| 106 | ;; Set it back to the default value. | 106 | ;; Set it back to the default value. NOTE: Using the default |
| 107 | (cl-declaim (optimize (safety 1)))) | 107 | ;; `safety' value does NOT give the default |
| 108 | ;; `byte-compile-delete-errors' value. Therefore limit this (and | ||
| 109 | ;; the above `cl-declaim') to compile time so that we don't affect | ||
| 110 | ;; code which only loads this library. | ||
| 111 | (eval-when-compile (cl-declaim (optimize (safety 1))))) | ||
| 108 | 112 | ||
| 109 | 113 | ||
| 110 | (eval-and-compile | 114 | (eval-and-compile |
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el index 2c49a634e35..eb2b2e3e11b 100644 --- a/lisp/emacs-lisp/ert.el +++ b/lisp/emacs-lisp/ert.el | |||
| @@ -670,48 +670,12 @@ and is displayed in front of the value of MESSAGE-FORM." | |||
| 670 | (cl-defstruct (ert-test-aborted-with-non-local-exit | 670 | (cl-defstruct (ert-test-aborted-with-non-local-exit |
| 671 | (:include ert-test-result))) | 671 | (:include ert-test-result))) |
| 672 | 672 | ||
| 673 | 673 | (defun ert--print-backtrace (backtrace do-xrefs) | |
| 674 | (defun ert--record-backtrace () | ||
| 675 | "Record the current backtrace (as a list) and return it." | ||
| 676 | ;; Since the backtrace is stored in the result object, result | ||
| 677 | ;; objects must only be printed with appropriate limits | ||
| 678 | ;; (`print-level' and `print-length') in place. For interactive | ||
| 679 | ;; use, the cost of ensuring this possibly outweighs the advantage | ||
| 680 | ;; of storing the backtrace for | ||
| 681 | ;; `ert-results-pop-to-backtrace-for-test-at-point' given that we | ||
| 682 | ;; already have `ert-results-rerun-test-debugging-errors-at-point'. | ||
| 683 | ;; For batch use, however, printing the backtrace may be useful. | ||
| 684 | (cl-loop | ||
| 685 | ;; 6 is the number of frames our own debugger adds (when | ||
| 686 | ;; compiled; more when interpreted). FIXME: Need to describe a | ||
| 687 | ;; procedure for determining this constant. | ||
| 688 | for i from 6 | ||
| 689 | for frame = (backtrace-frame i) | ||
| 690 | while frame | ||
| 691 | collect frame)) | ||
| 692 | |||
| 693 | (defun ert--print-backtrace (backtrace) | ||
| 694 | "Format the backtrace BACKTRACE to the current buffer." | 674 | "Format the backtrace BACKTRACE to the current buffer." |
| 695 | ;; This is essentially a reimplementation of Fbacktrace | ||
| 696 | ;; (src/eval.c), but for a saved backtrace, not the current one. | ||
| 697 | (let ((print-escape-newlines t) | 675 | (let ((print-escape-newlines t) |
| 698 | (print-level 8) | 676 | (print-level 8) |
| 699 | (print-length 50)) | 677 | (print-length 50)) |
| 700 | (dolist (frame backtrace) | 678 | (debugger-insert-backtrace backtrace do-xrefs))) |
| 701 | (pcase-exhaustive frame | ||
| 702 | (`(nil ,special-operator . ,arg-forms) | ||
| 703 | ;; Special operator. | ||
| 704 | (insert | ||
| 705 | (format " %S\n" (cons special-operator arg-forms)))) | ||
| 706 | (`(t ,fn . ,args) | ||
| 707 | ;; Function call. | ||
| 708 | (insert (format " %S(" fn)) | ||
| 709 | (cl-loop for firstp = t then nil | ||
| 710 | for arg in args do | ||
| 711 | (unless firstp | ||
| 712 | (insert " ")) | ||
| 713 | (insert (format "%S" arg))) | ||
| 714 | (insert ")\n")))))) | ||
| 715 | 679 | ||
| 716 | ;; A container for the state of the execution of a single test and | 680 | ;; A container for the state of the execution of a single test and |
| 717 | ;; environment data needed during its execution. | 681 | ;; environment data needed during its execution. |
| @@ -750,7 +714,19 @@ run. ARGS are the arguments to `debugger'." | |||
| 750 | ((quit) 'quit) | 714 | ((quit) 'quit) |
| 751 | ((ert-test-skipped) 'skipped) | 715 | ((ert-test-skipped) 'skipped) |
| 752 | (otherwise 'failed))) | 716 | (otherwise 'failed))) |
| 753 | (backtrace (ert--record-backtrace)) | 717 | ;; We store the backtrace in the result object for |
| 718 | ;; `ert-results-pop-to-backtrace-for-test-at-point'. | ||
| 719 | ;; This means we have to limit `print-level' and | ||
| 720 | ;; `print-length' when printing result objects. That | ||
| 721 | ;; might not be worth while when we can also use | ||
| 722 | ;; `ert-results-rerun-test-debugging-errors-at-point', | ||
| 723 | ;; (i.e., when running interactively) but having the | ||
| 724 | ;; backtrace ready for printing is important for batch | ||
| 725 | ;; use. | ||
| 726 | ;; | ||
| 727 | ;; Grab the frames starting from `signal', frames below | ||
| 728 | ;; that are all from the debugger. | ||
| 729 | (backtrace (backtrace-frames 'signal)) | ||
| 754 | (infos (reverse ert--infos))) | 730 | (infos (reverse ert--infos))) |
| 755 | (setf (ert--test-execution-info-result info) | 731 | (setf (ert--test-execution-info-result info) |
| 756 | (cl-ecase type | 732 | (cl-ecase type |
| @@ -1409,8 +1385,9 @@ Returns the stats object." | |||
| 1409 | (ert-test-result-with-condition | 1385 | (ert-test-result-with-condition |
| 1410 | (message "Test %S backtrace:" (ert-test-name test)) | 1386 | (message "Test %S backtrace:" (ert-test-name test)) |
| 1411 | (with-temp-buffer | 1387 | (with-temp-buffer |
| 1412 | (ert--print-backtrace (ert-test-result-with-condition-backtrace | 1388 | (ert--print-backtrace |
| 1413 | result)) | 1389 | (ert-test-result-with-condition-backtrace result) |
| 1390 | nil) | ||
| 1414 | (goto-char (point-min)) | 1391 | (goto-char (point-min)) |
| 1415 | (while (not (eobp)) | 1392 | (while (not (eobp)) |
| 1416 | (let ((start (point)) | 1393 | (let ((start (point)) |
| @@ -1491,7 +1468,7 @@ this exits Emacs, with status as per `ert-run-tests-batch-and-exit'." | |||
| 1491 | (with-temp-buffer | 1468 | (with-temp-buffer |
| 1492 | (while (setq logfile (pop command-line-args-left)) | 1469 | (while (setq logfile (pop command-line-args-left)) |
| 1493 | (erase-buffer) | 1470 | (erase-buffer) |
| 1494 | (insert-file-contents logfile) | 1471 | (when (file-readable-p logfile) (insert-file-contents logfile)) |
| 1495 | (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t)) | 1472 | (if (not (re-search-forward "^Running \\([0-9]+\\) tests" nil t)) |
| 1496 | (push logfile notests) | 1473 | (push logfile notests) |
| 1497 | (setq ntests (+ ntests (string-to-number (match-string 1)))) | 1474 | (setq ntests (+ ntests (string-to-number (match-string 1)))) |
| @@ -1828,12 +1805,23 @@ EWOC and STATS are arguments for `ert--results-update-stats-display'." | |||
| 1828 | 1805 | ||
| 1829 | BEGIN and END specify a region in the current buffer." | 1806 | BEGIN and END specify a region in the current buffer." |
| 1830 | (save-excursion | 1807 | (save-excursion |
| 1831 | (save-restriction | 1808 | (goto-char begin) |
| 1832 | (narrow-to-region begin end) | 1809 | (while (progn |
| 1833 | ;; Inhibit optimization in `debugger-make-xrefs' that would | 1810 | (goto-char (+ (point) 2)) |
| 1834 | ;; sometimes insert unrelated backtrace info into our buffer. | 1811 | (skip-syntax-forward "^w_") |
| 1835 | (let ((debugger-previous-backtrace nil)) | 1812 | (< (point) end)) |
| 1836 | (debugger-make-xrefs))))) | 1813 | (let* ((beg (point)) |
| 1814 | (end (progn (skip-syntax-forward "w_") (point))) | ||
| 1815 | (sym (intern-soft (buffer-substring-no-properties | ||
| 1816 | beg end))) | ||
| 1817 | (file (and sym (symbol-file sym 'defun)))) | ||
| 1818 | (when file | ||
| 1819 | (goto-char beg) | ||
| 1820 | ;; help-xref-button needs to operate on something matched | ||
| 1821 | ;; by a regexp, so set that up for it. | ||
| 1822 | (re-search-forward "\\(\\sw\\|\\s_\\)+") | ||
| 1823 | (help-xref-button 0 'help-function-def sym file))) | ||
| 1824 | (forward-line 1)))) | ||
| 1837 | 1825 | ||
| 1838 | (defun ert--string-first-line (s) | 1826 | (defun ert--string-first-line (s) |
| 1839 | "Return the first line of S, or S if it contains no newlines. | 1827 | "Return the first line of S, or S if it contains no newlines. |
| @@ -2420,8 +2408,7 @@ To be used in the ERT results buffer." | |||
| 2420 | ;; Use unibyte because `debugger-setup-buffer' also does so. | 2408 | ;; Use unibyte because `debugger-setup-buffer' also does so. |
| 2421 | (set-buffer-multibyte nil) | 2409 | (set-buffer-multibyte nil) |
| 2422 | (setq truncate-lines t) | 2410 | (setq truncate-lines t) |
| 2423 | (ert--print-backtrace backtrace) | 2411 | (ert--print-backtrace backtrace t) |
| 2424 | (debugger-make-xrefs) | ||
| 2425 | (goto-char (point-min)) | 2412 | (goto-char (point-min)) |
| 2426 | (insert (substitute-command-keys "Backtrace for test `")) | 2413 | (insert (substitute-command-keys "Backtrace for test `")) |
| 2427 | (ert-insert-test-name-button (ert-test-name test)) | 2414 | (ert-insert-test-name-button (ert-test-name test)) |
diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index fc3caf3359a..a1c5b6977f8 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el | |||
| @@ -326,12 +326,13 @@ Return argument is of the form (\"HOLDER\" \"YEAR1\" ... \"YEARN\")" | |||
| 326 | (start (point)) | 326 | (start (point)) |
| 327 | (end (line-end-position))) | 327 | (end (line-end-position))) |
| 328 | ;; Cope with multi-line copyright `lines'. Assume the second | 328 | ;; Cope with multi-line copyright `lines'. Assume the second |
| 329 | ;; line is indented (with the same commenting style). | 329 | ;; line is indented at least as much as the original, with the |
| 330 | ;; same commenting style. | ||
| 330 | (save-excursion | 331 | (save-excursion |
| 331 | (beginning-of-line 2) | 332 | (beginning-of-line 2) |
| 332 | (let ((str (concat (match-string-no-properties 1) "[ \t]+"))) | 333 | (let ((str (match-string-no-properties 1))) |
| 333 | (beginning-of-line) | 334 | (beginning-of-line) |
| 334 | (while (looking-at str) | 335 | (while (and (looking-at str) (not (looking-at lm-copyright-prefix))) |
| 335 | (setq end (line-end-position)) | 336 | (setq end (line-end-position)) |
| 336 | (beginning-of-line 2)))) | 337 | (beginning-of-line 2)))) |
| 337 | ;; Make a single line and parse that. | 338 | ;; Make a single line and parse that. |
diff --git a/lisp/epg.el b/lisp/epg.el index 587271b0003..1e24b8d1169 100644 --- a/lisp/epg.el +++ b/lisp/epg.el | |||
| @@ -1047,7 +1047,7 @@ callback data (if any)." | |||
| 1047 | (defun epg--status-TRUST_MARGINAL (context _string) | 1047 | (defun epg--status-TRUST_MARGINAL (context _string) |
| 1048 | (let ((signature (car (epg-context-result-for context 'verify)))) | 1048 | (let ((signature (car (epg-context-result-for context 'verify)))) |
| 1049 | (if (and signature | 1049 | (if (and signature |
| 1050 | (eq (epg-signature-status signature) 'marginal)) | 1050 | (eq (epg-signature-status signature) 'good)) |
| 1051 | (setf (epg-signature-validity signature) 'marginal)))) | 1051 | (setf (epg-signature-validity signature) 'marginal)))) |
| 1052 | 1052 | ||
| 1053 | (defun epg--status-TRUST_FULLY (context _string) | 1053 | (defun epg--status-TRUST_FULLY (context _string) |
diff --git a/lisp/eshell/esh-cmd.el b/lisp/eshell/esh-cmd.el index 86e7b83c281..24342208771 100644 --- a/lisp/eshell/esh-cmd.el +++ b/lisp/eshell/esh-cmd.el | |||
| @@ -1148,6 +1148,8 @@ be finished later after the completion of an asynchronous subprocess." | |||
| 1148 | 1148 | ||
| 1149 | ;; command invocation | 1149 | ;; command invocation |
| 1150 | 1150 | ||
| 1151 | (declare-function help-fns-function-description-header "help-fns") | ||
| 1152 | |||
| 1151 | (defun eshell/which (command &rest names) | 1153 | (defun eshell/which (command &rest names) |
| 1152 | "Identify the COMMAND, and where it is located." | 1154 | "Identify the COMMAND, and where it is located." |
| 1153 | (dolist (name (cons command names)) | 1155 | (dolist (name (cons command names)) |
| @@ -1164,25 +1166,17 @@ be finished later after the completion of an asynchronous subprocess." | |||
| 1164 | (concat name " is an alias, defined as \"" | 1166 | (concat name " is an alias, defined as \"" |
| 1165 | (cadr alias) "\""))) | 1167 | (cadr alias) "\""))) |
| 1166 | (unless program | 1168 | (unless program |
| 1167 | (setq program (eshell-search-path name)) | 1169 | (setq program |
| 1168 | (let* ((esym (eshell-find-alias-function name)) | 1170 | (let* ((esym (eshell-find-alias-function name)) |
| 1169 | (sym (or esym (intern-soft name)))) | 1171 | (sym (or esym (intern-soft name)))) |
| 1170 | (if (and (or esym (and sym (fboundp sym))) | 1172 | (if (and (or esym (and sym (fboundp sym))) |
| 1171 | (or eshell-prefer-lisp-functions (not direct))) | 1173 | (or eshell-prefer-lisp-functions (not direct))) |
| 1172 | (let ((desc (let ((inhibit-redisplay t)) | 1174 | (or (with-output-to-string |
| 1173 | (save-window-excursion | 1175 | (require 'help-fns) |
| 1174 | (prog1 | 1176 | (princ (format "%s is " sym)) |
| 1175 | (describe-function sym) | 1177 | (help-fns-function-description-header sym)) |
| 1176 | (message nil)))))) | 1178 | name) |
| 1177 | (setq desc (if desc (substring desc 0 | 1179 | (eshell-search-path name))))) |
| 1178 | (1- (or (string-match "\n" desc) | ||
| 1179 | (length desc)))) | ||
| 1180 | ;; This should not happen. | ||
| 1181 | (format "%s is defined, \ | ||
| 1182 | but no documentation was found" name))) | ||
| 1183 | (if (buffer-live-p (get-buffer "*Help*")) | ||
| 1184 | (kill-buffer "*Help*")) | ||
| 1185 | (setq program (or desc name)))))) | ||
| 1186 | (if (not program) | 1180 | (if (not program) |
| 1187 | (eshell-error (format "which: no %s in (%s)\n" | 1181 | (eshell-error (format "which: no %s in (%s)\n" |
| 1188 | name (getenv "PATH"))) | 1182 | name (getenv "PATH"))) |
diff --git a/lisp/frame.el b/lisp/frame.el index b7a55169281..b54df6fa160 100644 --- a/lisp/frame.el +++ b/lisp/frame.el | |||
| @@ -1110,6 +1110,38 @@ differing font heights." | |||
| 1110 | If FRAME is omitted, describe the currently selected frame." | 1110 | If FRAME is omitted, describe the currently selected frame." |
| 1111 | (cdr (assq 'width (frame-parameters frame)))) | 1111 | (cdr (assq 'width (frame-parameters frame)))) |
| 1112 | 1112 | ||
| 1113 | (defalias 'frame-border-width 'frame-internal-border-width) | ||
| 1114 | (defalias 'frame-pixel-width 'frame-native-width) | ||
| 1115 | (defalias 'frame-pixel-height 'frame-native-height) | ||
| 1116 | |||
| 1117 | (defun frame-inner-width (&optional frame) | ||
| 1118 | "Return inner width of FRAME in pixels. | ||
| 1119 | FRAME defaults to the selected frame." | ||
| 1120 | (setq frame (window-normalize-frame frame)) | ||
| 1121 | (- (frame-native-width frame) | ||
| 1122 | (* 2 (frame-internal-border-width frame)))) | ||
| 1123 | |||
| 1124 | (defun frame-inner-height (&optional frame) | ||
| 1125 | "Return inner height of FRAME in pixels. | ||
| 1126 | FRAME defaults to the selected frame." | ||
| 1127 | (setq frame (window-normalize-frame frame)) | ||
| 1128 | (- (frame-native-height frame) | ||
| 1129 | (* 2 (frame-internal-border-width frame)))) | ||
| 1130 | |||
| 1131 | (defun frame-outer-width (&optional frame) | ||
| 1132 | "Return outer width of FRAME in pixels. | ||
| 1133 | FRAME defaults to the selected frame." | ||
| 1134 | (setq frame (window-normalize-frame frame)) | ||
| 1135 | (let ((edges (frame-edges frame 'outer-edges))) | ||
| 1136 | (- (nth 2 edges) (nth 0 edges)))) | ||
| 1137 | |||
| 1138 | (defun frame-outer-height (&optional frame) | ||
| 1139 | "Return outer height of FRAME in pixels. | ||
| 1140 | FRAME defaults to the selected frame." | ||
| 1141 | (setq frame (window-normalize-frame frame)) | ||
| 1142 | (let ((edges (frame-edges frame 'outer-edges))) | ||
| 1143 | (- (nth 3 edges) (nth 1 edges)))) | ||
| 1144 | |||
| 1113 | (declare-function x-list-fonts "xfaces.c" | 1145 | (declare-function x-list-fonts "xfaces.c" |
| 1114 | (pattern &optional face frame maximum width)) | 1146 | (pattern &optional face frame maximum width)) |
| 1115 | 1147 | ||
diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 2c635ffa500..32324ae3bcb 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el | |||
| @@ -560,8 +560,9 @@ FILE is the file where FUNCTION was probably defined." | |||
| 560 | (setq short rel)))) | 560 | (setq short rel)))) |
| 561 | short)) | 561 | short)) |
| 562 | 562 | ||
| 563 | ;;;###autoload | 563 | (defun help-fns--analyse-function (function) |
| 564 | (defun describe-function-1 (function) | 564 | "Return information about FUNCTION. |
| 565 | Returns a list of the form (REAL-FUNCTION DEF ALIASED REAL-DEF)." | ||
| 565 | (let* ((advised (and (symbolp function) | 566 | (let* ((advised (and (symbolp function) |
| 566 | (featurep 'nadvice) | 567 | (featurep 'nadvice) |
| 567 | (advice--p (advice--symbol-function function)))) | 568 | (advice--p (advice--symbol-function function)))) |
| @@ -594,22 +595,24 @@ FILE is the file where FUNCTION was probably defined." | |||
| 594 | (setq f (symbol-function f))) | 595 | (setq f (symbol-function f))) |
| 595 | f)) | 596 | f)) |
| 596 | ((subrp def) (intern (subr-name def))) | 597 | ((subrp def) (intern (subr-name def))) |
| 597 | (t def))) | 598 | (t def)))) |
| 598 | (sig-key (if (subrp def) | 599 | (list real-function def aliased real-def))) |
| 599 | (indirect-function real-def) | 600 | |
| 600 | real-def)) | 601 | (defun help-fns-function-description-header (function) |
| 601 | (file-name (find-lisp-object-file-name function (if aliased 'defun | 602 | "Print a line describing FUNCTION to `standard-output'." |
| 602 | def))) | 603 | (pcase-let* ((`(,_real-function ,def ,aliased ,real-def) |
| 603 | (pt1 (with-current-buffer (help-buffer) (point))) | 604 | (help-fns--analyse-function function)) |
| 604 | (beg (if (and (or (byte-code-function-p def) | 605 | (file-name (find-lisp-object-file-name function (if aliased 'defun |
| 605 | (keymapp def) | 606 | def))) |
| 606 | (memq (car-safe def) '(macro lambda closure))) | 607 | (beg (if (and (or (byte-code-function-p def) |
| 607 | (stringp file-name) | 608 | (keymapp def) |
| 608 | (help-fns--autoloaded-p function file-name)) | 609 | (memq (car-safe def) '(macro lambda closure))) |
| 609 | (if (commandp def) | 610 | (stringp file-name) |
| 610 | "an interactive autoloaded " | 611 | (help-fns--autoloaded-p function file-name)) |
| 611 | "an autoloaded ") | 612 | (if (commandp def) |
| 612 | (if (commandp def) "an interactive " "a ")))) | 613 | "an interactive autoloaded " |
| 614 | "an autoloaded ") | ||
| 615 | (if (commandp def) "an interactive " "a ")))) | ||
| 613 | 616 | ||
| 614 | ;; Print what kind of function-like object FUNCTION is. | 617 | ;; Print what kind of function-like object FUNCTION is. |
| 615 | (princ (cond ((or (stringp def) (vectorp def)) | 618 | (princ (cond ((or (stringp def) (vectorp def)) |
| @@ -676,34 +679,42 @@ FILE is the file where FUNCTION was probably defined." | |||
| 676 | (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") | 679 | (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") |
| 677 | nil t) | 680 | nil t) |
| 678 | (help-xref-button 1 'help-function-def function file-name)))) | 681 | (help-xref-button 1 'help-function-def function file-name)))) |
| 679 | (princ ".") | 682 | (princ ".")))) |
| 680 | (with-current-buffer (help-buffer) | 683 | |
| 681 | (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point)) | 684 | ;;;###autoload |
| 682 | (point))) | 685 | (defun describe-function-1 (function) |
| 683 | (terpri)(terpri) | 686 | (let ((pt1 (with-current-buffer (help-buffer) (point)))) |
| 684 | 687 | (help-fns-function-description-header function) | |
| 685 | (let ((doc-raw (documentation function t)) | 688 | (with-current-buffer (help-buffer) |
| 686 | (key-bindings-buffer (current-buffer))) | 689 | (fill-region-as-paragraph (save-excursion (goto-char pt1) (forward-line 0) (point)) |
| 687 | 690 | (point)))) | |
| 688 | ;; If the function is autoloaded, and its docstring has | 691 | (terpri)(terpri) |
| 689 | ;; key substitution constructs, load the library. | 692 | |
| 690 | (and (autoloadp real-def) doc-raw | 693 | (pcase-let ((`(,real-function ,def ,_aliased ,real-def) |
| 691 | help-enable-auto-load | 694 | (help-fns--analyse-function function)) |
| 692 | (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) | 695 | (doc-raw (documentation function t)) |
| 693 | (autoload-do-load real-def)) | 696 | (key-bindings-buffer (current-buffer))) |
| 694 | 697 | ||
| 695 | (help-fns--key-bindings function) | 698 | ;; If the function is autoloaded, and its docstring has |
| 696 | (with-current-buffer standard-output | 699 | ;; key substitution constructs, load the library. |
| 697 | (let ((doc (help-fns--signature function doc-raw sig-key | 700 | (and (autoloadp real-def) doc-raw |
| 698 | real-function key-bindings-buffer))) | 701 | help-enable-auto-load |
| 699 | (run-hook-with-args 'help-fns-describe-function-functions function) | 702 | (string-match "\\([^\\]=\\|[^=]\\|\\`\\)\\\\[[{<]" doc-raw) |
| 700 | (insert "\n" | 703 | (autoload-do-load real-def)) |
| 701 | (or doc "Not documented.")) | 704 | |
| 702 | ;; Avoid asking the user annoying questions if she decides | 705 | (help-fns--key-bindings function) |
| 703 | ;; to save the help buffer, when her locale's codeset | 706 | (with-current-buffer standard-output |
| 704 | ;; isn't UTF-8. | 707 | (let ((doc (help-fns--signature |
| 705 | (unless (memq text-quoting-style '(straight grave)) | 708 | function doc-raw |
| 706 | (set-buffer-file-coding-system 'utf-8)))))))) | 709 | (if (subrp def) (indirect-function real-def) real-def) |
| 710 | real-function key-bindings-buffer))) | ||
| 711 | (run-hook-with-args 'help-fns-describe-function-functions function) | ||
| 712 | (insert "\n" (or doc "Not documented."))) | ||
| 713 | ;; Avoid asking the user annoying questions if she decides | ||
| 714 | ;; to save the help buffer, when her locale's codeset | ||
| 715 | ;; isn't UTF-8. | ||
| 716 | (unless (memq text-quoting-style '(straight grave)) | ||
| 717 | (set-buffer-file-coding-system 'utf-8))))) | ||
| 707 | 718 | ||
| 708 | ;; Add defaults to `help-fns-describe-function-functions'. | 719 | ;; Add defaults to `help-fns-describe-function-functions'. |
| 709 | (add-hook 'help-fns-describe-function-functions #'help-fns--obsolete) | 720 | (add-hook 'help-fns-describe-function-functions #'help-fns--obsolete) |
diff --git a/lisp/help.el b/lisp/help.el index 361ab2a01ee..0fb1c2dab77 100644 --- a/lisp/help.el +++ b/lisp/help.el | |||
| @@ -593,6 +593,39 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." | |||
| 593 | string | 593 | string |
| 594 | (format "%s (translated from %s)" string otherstring)))))) | 594 | (format "%s (translated from %s)" string otherstring)))))) |
| 595 | 595 | ||
| 596 | (defun help--analyze-key (key untranslated) | ||
| 597 | "Get information about KEY its corresponding UNTRANSLATED events. | ||
| 598 | Returns a list of the form (BRIEF-DESC DEFN EVENT MOUSE-MSG)." | ||
| 599 | (if (numberp untranslated) | ||
| 600 | (setq untranslated (this-single-command-raw-keys))) | ||
| 601 | (let* ((event (aref key (if (and (symbolp (aref key 0)) | ||
| 602 | (> (length key) 1) | ||
| 603 | (consp (aref key 1))) | ||
| 604 | 1 | ||
| 605 | 0))) | ||
| 606 | (modifiers (event-modifiers event)) | ||
| 607 | (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers) | ||
| 608 | (memq 'drag modifiers)) " at that spot" "")) | ||
| 609 | (defn (key-binding key t))) | ||
| 610 | ;; Handle the case where we faked an entry in "Select and Paste" menu. | ||
| 611 | (when (and (eq defn nil) | ||
| 612 | (stringp (aref key (1- (length key)))) | ||
| 613 | (eq (key-binding (substring key 0 -1)) 'yank-menu)) | ||
| 614 | (setq defn 'menu-bar-select-yank)) | ||
| 615 | ;; Don't bother user with strings from (e.g.) the select-paste menu. | ||
| 616 | (when (stringp (aref key (1- (length key)))) | ||
| 617 | (aset key (1- (length key)) "(any string)")) | ||
| 618 | (when (and untranslated | ||
| 619 | (stringp (aref untranslated (1- (length untranslated))))) | ||
| 620 | (aset untranslated (1- (length untranslated)) "(any string)")) | ||
| 621 | (list | ||
| 622 | ;; Now describe the key, perhaps as changed. | ||
| 623 | (let ((key-desc (help-key-description key untranslated))) | ||
| 624 | (if (or (null defn) (integerp defn) (equal defn 'undefined)) | ||
| 625 | (format "%s%s is undefined" key-desc mouse-msg) | ||
| 626 | (format "%s%s runs the command %S" key-desc mouse-msg defn))) | ||
| 627 | defn event mouse-msg))) | ||
| 628 | |||
| 596 | (defun describe-key-briefly (&optional key insert untranslated) | 629 | (defun describe-key-briefly (&optional key insert untranslated) |
| 597 | "Print the name of the function KEY invokes. KEY is a string. | 630 | "Print the name of the function KEY invokes. KEY is a string. |
| 598 | If INSERT (the prefix arg) is non-nil, insert the message in the buffer. | 631 | If INSERT (the prefix arg) is non-nil, insert the message in the buffer. |
| @@ -603,73 +636,12 @@ the last key hit are used. | |||
| 603 | If KEY is a menu item or a tool-bar button that is disabled, this command | 636 | If KEY is a menu item or a tool-bar button that is disabled, this command |
| 604 | temporarily enables it to allow getting help on disabled items and buttons." | 637 | temporarily enables it to allow getting help on disabled items and buttons." |
| 605 | (interactive | 638 | (interactive |
| 606 | (let ((enable-disabled-menus-and-buttons t) | 639 | ;; Ignore mouse movement events because it's too easy to miss the |
| 607 | (cursor-in-echo-area t) | 640 | ;; message while moving the mouse. |
| 608 | saved-yank-menu) | 641 | (pcase-let ((`(,key ,_up-event) (help-read-key-sequence 'no-mouse-movement))) |
| 609 | (unwind-protect | 642 | `(,key ,current-prefix-arg 1))) |
| 610 | (let (key) | 643 | (princ (car (help--analyze-key key untranslated)) |
| 611 | ;; If yank-menu is empty, populate it temporarily, so that | 644 | (if insert (current-buffer) standard-output))) |
| 612 | ;; "Select and Paste" menu can generate a complete event. | ||
| 613 | (when (null (cdr yank-menu)) | ||
| 614 | (setq saved-yank-menu (copy-sequence yank-menu)) | ||
| 615 | (menu-bar-update-yank-menu "(any string)" nil)) | ||
| 616 | (while | ||
| 617 | (progn | ||
| 618 | (setq key (read-key-sequence "Describe the following key, mouse click, or menu item: ")) | ||
| 619 | (and (vectorp key) | ||
| 620 | (consp (aref key 0)) | ||
| 621 | (symbolp (car (aref key 0))) | ||
| 622 | (string-match "\\(mouse\\|down\\|click\\|drag\\)" | ||
| 623 | (symbol-name (car (aref key 0)))) | ||
| 624 | (not (sit-for (/ double-click-time 1000.0) t))))) | ||
| 625 | ;; Clear the echo area message (Bug#7014). | ||
| 626 | (message nil) | ||
| 627 | ;; If KEY is a down-event, read and discard the | ||
| 628 | ;; corresponding up-event. Note that there are also | ||
| 629 | ;; down-events on scroll bars and mode lines: the actual | ||
| 630 | ;; event then is in the second element of the vector. | ||
| 631 | (and (vectorp key) | ||
| 632 | (let ((last-idx (1- (length key)))) | ||
| 633 | (and (eventp (aref key last-idx)) | ||
| 634 | (memq 'down (event-modifiers (aref key last-idx))))) | ||
| 635 | (read-event)) | ||
| 636 | (list | ||
| 637 | key | ||
| 638 | (if current-prefix-arg (prefix-numeric-value current-prefix-arg)) | ||
| 639 | 1)) | ||
| 640 | ;; Put yank-menu back as it was, if we changed it. | ||
| 641 | (when saved-yank-menu | ||
| 642 | (setq yank-menu (copy-sequence saved-yank-menu)) | ||
| 643 | (fset 'yank-menu (cons 'keymap yank-menu)))))) | ||
| 644 | (if (numberp untranslated) | ||
| 645 | (setq untranslated (this-single-command-raw-keys))) | ||
| 646 | (let* ((event (if (and (symbolp (aref key 0)) | ||
| 647 | (> (length key) 1) | ||
| 648 | (consp (aref key 1))) | ||
| 649 | (aref key 1) | ||
| 650 | (aref key 0))) | ||
| 651 | (modifiers (event-modifiers event)) | ||
| 652 | (standard-output (if insert (current-buffer) standard-output)) | ||
| 653 | (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers) | ||
| 654 | (memq 'drag modifiers)) " at that spot" "")) | ||
| 655 | (defn (key-binding key t)) | ||
| 656 | key-desc) | ||
| 657 | ;; Handle the case where we faked an entry in "Select and Paste" menu. | ||
| 658 | (if (and (eq defn nil) | ||
| 659 | (stringp (aref key (1- (length key)))) | ||
| 660 | (eq (key-binding (substring key 0 -1)) 'yank-menu)) | ||
| 661 | (setq defn 'menu-bar-select-yank)) | ||
| 662 | ;; Don't bother user with strings from (e.g.) the select-paste menu. | ||
| 663 | (if (stringp (aref key (1- (length key)))) | ||
| 664 | (aset key (1- (length key)) "(any string)")) | ||
| 665 | (if (and (> (length untranslated) 0) | ||
| 666 | (stringp (aref untranslated (1- (length untranslated))))) | ||
| 667 | (aset untranslated (1- (length untranslated)) "(any string)")) | ||
| 668 | ;; Now describe the key, perhaps as changed. | ||
| 669 | (setq key-desc (help-key-description key untranslated)) | ||
| 670 | (if (or (null defn) (integerp defn) (equal defn 'undefined)) | ||
| 671 | (princ (format "%s%s is undefined" key-desc mouse-msg)) | ||
| 672 | (princ (format "%s%s runs the command %S" key-desc mouse-msg defn))))) | ||
| 673 | 645 | ||
| 674 | (defun help--key-binding-keymap (key &optional accept-default no-remap position) | 646 | (defun help--key-binding-keymap (key &optional accept-default no-remap position) |
| 675 | "Return a keymap holding a binding for KEY within current keymaps. | 647 | "Return a keymap holding a binding for KEY within current keymaps. |
| @@ -734,6 +706,59 @@ function `key-binding'." | |||
| 734 | (throw 'found x)))) | 706 | (throw 'found x)))) |
| 735 | nil))))) | 707 | nil))))) |
| 736 | 708 | ||
| 709 | (defun help-read-key-sequence (&optional no-mouse-movement) | ||
| 710 | "Reads a key sequence from the user. | ||
| 711 | Returns a list of the form (KEY UP-EVENT), where KEY is the key | ||
| 712 | sequence, and UP-EVENT is the up-event that was discarded by | ||
| 713 | reading KEY, or nil. | ||
| 714 | If NO-MOUSE-MOVEMENT is non-nil, ignore key sequences starting | ||
| 715 | with `mouse-movement' events." | ||
| 716 | (let ((enable-disabled-menus-and-buttons t) | ||
| 717 | (cursor-in-echo-area t) | ||
| 718 | saved-yank-menu) | ||
| 719 | (unwind-protect | ||
| 720 | (let (key) | ||
| 721 | ;; If yank-menu is empty, populate it temporarily, so that | ||
| 722 | ;; "Select and Paste" menu can generate a complete event. | ||
| 723 | (when (null (cdr yank-menu)) | ||
| 724 | (setq saved-yank-menu (copy-sequence yank-menu)) | ||
| 725 | (menu-bar-update-yank-menu "(any string)" nil)) | ||
| 726 | (while | ||
| 727 | (pcase (setq key (read-key-sequence "\ | ||
| 728 | Describe the following key, mouse click, or menu item: ")) | ||
| 729 | ((and (pred vectorp) (let `(,key0 . ,_) (aref key 0)) | ||
| 730 | (guard (symbolp key0)) (let keyname (symbol-name key0))) | ||
| 731 | (if no-mouse-movement | ||
| 732 | (string-match "mouse-movement" keyname) | ||
| 733 | (and (string-match "\\(mouse\\|down\\|click\\|drag\\)" | ||
| 734 | keyname) | ||
| 735 | (not (sit-for (/ double-click-time 1000.0) t))))))) | ||
| 736 | (list | ||
| 737 | key | ||
| 738 | ;; If KEY is a down-event, read and include the | ||
| 739 | ;; corresponding up-event. Note that there are also | ||
| 740 | ;; down-events on scroll bars and mode lines: the actual | ||
| 741 | ;; event then is in the second element of the vector. | ||
| 742 | (and (vectorp key) | ||
| 743 | (let ((last-idx (1- (length key)))) | ||
| 744 | (and (eventp (aref key last-idx)) | ||
| 745 | (memq 'down (event-modifiers (aref key last-idx))))) | ||
| 746 | (or (and (eventp (aref key 0)) | ||
| 747 | (memq 'down (event-modifiers (aref key 0))) | ||
| 748 | ;; However, for the C-down-mouse-2 popup | ||
| 749 | ;; menu, there is no subsequent up-event. In | ||
| 750 | ;; this case, the up-event is the next | ||
| 751 | ;; element in the supplied vector. | ||
| 752 | (= (length key) 1)) | ||
| 753 | (and (> (length key) 1) | ||
| 754 | (eventp (aref key 1)) | ||
| 755 | (memq 'down (event-modifiers (aref key 1))))) | ||
| 756 | (read-event)))) | ||
| 757 | ;; Put yank-menu back as it was, if we changed it. | ||
| 758 | (when saved-yank-menu | ||
| 759 | (setq yank-menu (copy-sequence saved-yank-menu)) | ||
| 760 | (fset 'yank-menu (cons 'keymap yank-menu)))))) | ||
| 761 | |||
| 737 | (defun describe-key (&optional key untranslated up-event) | 762 | (defun describe-key (&optional key untranslated up-event) |
| 738 | "Display documentation of the function invoked by KEY. | 763 | "Display documentation of the function invoked by KEY. |
| 739 | KEY can be any kind of a key sequence; it can include keyboard events, | 764 | KEY can be any kind of a key sequence; it can include keyboard events, |
| @@ -748,83 +773,20 @@ UP-EVENT is the up-event that was discarded by reading KEY, or nil. | |||
| 748 | If KEY is a menu item or a tool-bar button that is disabled, this command | 773 | If KEY is a menu item or a tool-bar button that is disabled, this command |
| 749 | temporarily enables it to allow getting help on disabled items and buttons." | 774 | temporarily enables it to allow getting help on disabled items and buttons." |
| 750 | (interactive | 775 | (interactive |
| 751 | (let ((enable-disabled-menus-and-buttons t) | 776 | (pcase-let ((`(,key ,up-event) (help-read-key-sequence))) |
| 752 | (cursor-in-echo-area t) | 777 | `(,key ,(prefix-numeric-value current-prefix-arg) ,up-event))) |
| 753 | saved-yank-menu) | 778 | (pcase-let ((`(,brief-desc ,defn ,event ,mouse-msg) |
| 754 | (unwind-protect | 779 | (help--analyze-key key untranslated)) |
| 755 | (let (key) | 780 | (defn-up nil) (defn-up-tricky nil) |
| 756 | ;; If yank-menu is empty, populate it temporarily, so that | 781 | (key-locus-up nil) (key-locus-up-tricky nil) |
| 757 | ;; "Select and Paste" menu can generate a complete event. | 782 | (mouse-1-remapped nil) (mouse-1-tricky nil) |
| 758 | (when (null (cdr yank-menu)) | 783 | (ev-type nil)) |
| 759 | (setq saved-yank-menu (copy-sequence yank-menu)) | 784 | (if (or (null defn) |
| 760 | (menu-bar-update-yank-menu "(any string)" nil)) | 785 | (integerp defn) |
| 761 | (while | 786 | (equal defn 'undefined)) |
| 762 | (progn | 787 | (message "%s" brief-desc) |
| 763 | (setq key (read-key-sequence "Describe the following key, mouse click, or menu item: ")) | ||
| 764 | (and (vectorp key) | ||
| 765 | (consp (aref key 0)) | ||
| 766 | (symbolp (car (aref key 0))) | ||
| 767 | (string-match "\\(mouse\\|down\\|click\\|drag\\)" | ||
| 768 | (symbol-name (car (aref key 0)))) | ||
| 769 | (not (sit-for (/ double-click-time 1000.0) t))))) | ||
| 770 | (list | ||
| 771 | key | ||
| 772 | (prefix-numeric-value current-prefix-arg) | ||
| 773 | ;; If KEY is a down-event, read and include the | ||
| 774 | ;; corresponding up-event. Note that there are also | ||
| 775 | ;; down-events on scroll bars and mode lines: the actual | ||
| 776 | ;; event then is in the second element of the vector. | ||
| 777 | (and (vectorp key) | ||
| 778 | (let ((last-idx (1- (length key)))) | ||
| 779 | (and (eventp (aref key last-idx)) | ||
| 780 | (memq 'down (event-modifiers (aref key last-idx))))) | ||
| 781 | (or (and (eventp (aref key 0)) | ||
| 782 | (memq 'down (event-modifiers (aref key 0))) | ||
| 783 | ;; However, for the C-down-mouse-2 popup | ||
| 784 | ;; menu, there is no subsequent up-event. In | ||
| 785 | ;; this case, the up-event is the next | ||
| 786 | ;; element in the supplied vector. | ||
| 787 | (= (length key) 1)) | ||
| 788 | (and (> (length key) 1) | ||
| 789 | (eventp (aref key 1)) | ||
| 790 | (memq 'down (event-modifiers (aref key 1))))) | ||
| 791 | (read-event)))) | ||
| 792 | ;; Put yank-menu back as it was, if we changed it. | ||
| 793 | (when saved-yank-menu | ||
| 794 | (setq yank-menu (copy-sequence saved-yank-menu)) | ||
| 795 | (fset 'yank-menu (cons 'keymap yank-menu)))))) | ||
| 796 | (if (numberp untranslated) | ||
| 797 | (setq untranslated (this-single-command-raw-keys))) | ||
| 798 | (let* ((event (aref key (if (and (symbolp (aref key 0)) | ||
| 799 | (> (length key) 1) | ||
| 800 | (consp (aref key 1))) | ||
| 801 | 1 | ||
| 802 | 0))) | ||
| 803 | (modifiers (event-modifiers event)) | ||
| 804 | (mouse-msg (if (or (memq 'click modifiers) (memq 'down modifiers) | ||
| 805 | (memq 'drag modifiers)) " at that spot" "")) | ||
| 806 | (defn (key-binding key t)) | ||
| 807 | key-locus key-locus-up key-locus-up-tricky | ||
| 808 | defn-up defn-up-tricky ev-type | ||
| 809 | mouse-1-remapped mouse-1-tricky) | ||
| 810 | |||
| 811 | ;; Handle the case where we faked an entry in "Select and Paste" menu. | ||
| 812 | (when (and (eq defn nil) | ||
| 813 | (stringp (aref key (1- (length key)))) | ||
| 814 | (eq (key-binding (substring key 0 -1)) 'yank-menu)) | ||
| 815 | (setq defn 'menu-bar-select-yank)) | ||
| 816 | (if (or (null defn) (integerp defn) (equal defn 'undefined)) | ||
| 817 | (message "%s%s is undefined" | ||
| 818 | (help-key-description key untranslated) mouse-msg) | ||
| 819 | (help-setup-xref (list #'describe-function defn) | 788 | (help-setup-xref (list #'describe-function defn) |
| 820 | (called-interactively-p 'interactive)) | 789 | (called-interactively-p 'interactive)) |
| 821 | ;; Don't bother user with strings from (e.g.) the select-paste menu. | ||
| 822 | (when (stringp (aref key (1- (length key)))) | ||
| 823 | (aset key (1- (length key)) "(any string)")) | ||
| 824 | (when (and untranslated | ||
| 825 | (stringp (aref untranslated (1- (length untranslated))))) | ||
| 826 | (aset untranslated (1- (length untranslated)) | ||
| 827 | "(any string)")) | ||
| 828 | ;; Need to do this before erasing *Help* buffer in case event | 790 | ;; Need to do this before erasing *Help* buffer in case event |
| 829 | ;; is a mouse click in an existing *Help* buffer. | 791 | ;; is a mouse click in an existing *Help* buffer. |
| 830 | (when up-event | 792 | (when up-event |
| @@ -849,13 +811,12 @@ temporarily enables it to allow getting help on disabled items and buttons." | |||
| 849 | (aset sequence 0 'mouse-1) | 811 | (aset sequence 0 'mouse-1) |
| 850 | (setq defn-up-tricky (key-binding sequence nil nil (event-start up-event))) | 812 | (setq defn-up-tricky (key-binding sequence nil nil (event-start up-event))) |
| 851 | (setq key-locus-up-tricky (help--binding-locus sequence (event-start up-event)))))) | 813 | (setq key-locus-up-tricky (help--binding-locus sequence (event-start up-event)))))) |
| 852 | (setq key-locus (help--binding-locus key (event-start event))) | ||
| 853 | (with-help-window (help-buffer) | 814 | (with-help-window (help-buffer) |
| 854 | (princ (help-key-description key untranslated)) | 815 | (princ brief-desc) |
| 855 | (princ (format "%s runs the command %S%s, which is " | 816 | (let ((key-locus (help--binding-locus key (event-start event)))) |
| 856 | mouse-msg defn (if key-locus | 817 | (when key-locus |
| 857 | (format " (found in %s)" key-locus) | 818 | (princ (format " (found in %s)" key-locus)))) |
| 858 | ""))) | 819 | (princ ", which is ") |
| 859 | (describe-function-1 defn) | 820 | (describe-function-1 defn) |
| 860 | (when up-event | 821 | (when up-event |
| 861 | (unless (or (null defn-up) | 822 | (unless (or (null defn-up) |
diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index ae28ba93e61..dababdb4fa6 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el | |||
| @@ -4952,7 +4952,7 @@ call other entry points instead, such as `cl-prin1'. | |||
| 4952 | 4952 | ||
| 4953 | \(fn OBJECT)" nil nil) | 4953 | \(fn OBJECT)" nil nil) |
| 4954 | 4954 | ||
| 4955 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-print" '("cl-print-"))) | 4955 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-print" '("cl-print-" "help-byte-code"))) |
| 4956 | 4956 | ||
| 4957 | ;;;*** | 4957 | ;;;*** |
| 4958 | 4958 | ||
| @@ -16544,18 +16544,6 @@ The optional LABEL is used to label the buffer created. | |||
| 16544 | 16544 | ||
| 16545 | ;;;*** | 16545 | ;;;*** |
| 16546 | 16546 | ||
| 16547 | ;;;### (autoloads nil "html2text" "net/html2text.el" (0 0 0 0)) | ||
| 16548 | ;;; Generated autoloads from net/html2text.el | ||
| 16549 | |||
| 16550 | (autoload 'html2text "html2text" "\ | ||
| 16551 | Convert HTML to plain text in the current buffer. | ||
| 16552 | |||
| 16553 | \(fn)" t nil) | ||
| 16554 | |||
| 16555 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "html2text" '("html2text-"))) | ||
| 16556 | |||
| 16557 | ;;;*** | ||
| 16558 | |||
| 16559 | ;;;### (autoloads nil "htmlfontify" "htmlfontify.el" (0 0 0 0)) | 16547 | ;;;### (autoloads nil "htmlfontify" "htmlfontify.el" (0 0 0 0)) |
| 16560 | ;;; Generated autoloads from htmlfontify.el | 16548 | ;;; Generated autoloads from htmlfontify.el |
| 16561 | (push (purecopy '(htmlfontify 0 21)) package--builtin-versions) | 16549 | (push (purecopy '(htmlfontify 0 21)) package--builtin-versions) |
| @@ -30399,7 +30387,7 @@ then `snmpv2-mode-hook'. | |||
| 30399 | 30387 | ||
| 30400 | ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) | 30388 | ;;;### (autoloads nil "soap-client" "net/soap-client.el" (0 0 0 0)) |
| 30401 | ;;; Generated autoloads from net/soap-client.el | 30389 | ;;; Generated autoloads from net/soap-client.el |
| 30402 | (push (purecopy '(soap-client 3 1 2)) package--builtin-versions) | 30390 | (push (purecopy '(soap-client 3 1 3)) package--builtin-versions) |
| 30403 | 30391 | ||
| 30404 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-client" '("soap-"))) | 30392 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "soap-client" '("soap-"))) |
| 30405 | 30393 | ||
| @@ -34165,7 +34153,7 @@ Reenable Ange-FTP, when Tramp is unloaded. | |||
| 34165 | 34153 | ||
| 34166 | ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) | 34154 | ;;;### (autoloads nil "trampver" "net/trampver.el" (0 0 0 0)) |
| 34167 | ;;; Generated autoloads from net/trampver.el | 34155 | ;;; Generated autoloads from net/trampver.el |
| 34168 | (push (purecopy '(tramp 2 3 2 -1)) package--builtin-versions) | 34156 | (push (purecopy '(tramp 2 3 2)) package--builtin-versions) |
| 34169 | 34157 | ||
| 34170 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) | 34158 | (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "trampver" '("tramp-"))) |
| 34171 | 34159 | ||
diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index c3480cd6c64..e5b1029c01f 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el | |||
| @@ -746,7 +746,7 @@ If the current buffer is not a minibuffer, erase its entire contents." | |||
| 746 | 746 | ||
| 747 | (defcustom completion-auto-help t | 747 | (defcustom completion-auto-help t |
| 748 | "Non-nil means automatically provide help for invalid completion input. | 748 | "Non-nil means automatically provide help for invalid completion input. |
| 749 | If the value is t the *Completion* buffer is displayed whenever completion | 749 | If the value is t the *Completions* buffer is displayed whenever completion |
| 750 | is requested but cannot be done. | 750 | is requested but cannot be done. |
| 751 | If the value is `lazy', the *Completions* buffer is only displayed after | 751 | If the value is `lazy', the *Completions* buffer is only displayed after |
| 752 | the second failed attempt to complete." | 752 | the second failed attempt to complete." |
diff --git a/lisp/mouse.el b/lisp/mouse.el index 9b6b169e568..e0794435d7a 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el | |||
| @@ -380,7 +380,7 @@ This command must be bound to a mouse click." | |||
| 380 | 380 | ||
| 381 | (defun mouse-drag-line (start-event line) | 381 | (defun mouse-drag-line (start-event line) |
| 382 | "Drag a mode line, header line, or vertical line with the mouse. | 382 | "Drag a mode line, header line, or vertical line with the mouse. |
| 383 | START-EVENT is the starting mouse-event of the drag action. LINE | 383 | START-EVENT is the starting mouse event of the drag action. LINE |
| 384 | must be one of the symbols `header', `mode', or `vertical'." | 384 | must be one of the symbols `header', `mode', or `vertical'." |
| 385 | ;; Give temporary modes such as isearch a chance to turn off. | 385 | ;; Give temporary modes such as isearch a chance to turn off. |
| 386 | (run-hooks 'mouse-leave-buffer-hook) | 386 | (run-hooks 'mouse-leave-buffer-hook) |
| @@ -405,29 +405,15 @@ must be one of the symbols `header', `mode', or `vertical'." | |||
| 405 | ;; window's edge we drag. | 405 | ;; window's edge we drag. |
| 406 | (cond | 406 | (cond |
| 407 | ((eq line 'header) | 407 | ((eq line 'header) |
| 408 | (if (window-at-side-p window 'top) | 408 | ;; Drag bottom edge of window above the header line. |
| 409 | ;; We can't drag the header line of a topmost window. | 409 | (setq window (window-in-direction 'above window t))) |
| 410 | (setq draggable nil) | 410 | ((eq line 'mode)) |
| 411 | ;; Drag bottom edge of window above the header line. | ||
| 412 | (setq window (window-in-direction 'above window t)))) | ||
| 413 | ((eq line 'mode) | ||
| 414 | (if (and (window-at-side-p window 'bottom) | ||
| 415 | ;; Allow resizing the minibuffer window if it's on the | ||
| 416 | ;; same frame as and immediately below `window', and it's | ||
| 417 | ;; either active or `resize-mini-windows' is nil. | ||
| 418 | (let ((minibuffer-window (minibuffer-window frame))) | ||
| 419 | (not (and (eq (window-frame minibuffer-window) frame) | ||
| 420 | (or (not resize-mini-windows) | ||
| 421 | (eq minibuffer-window | ||
| 422 | (active-minibuffer-window))))))) | ||
| 423 | (setq draggable nil))) | ||
| 424 | ((eq line 'vertical) | 411 | ((eq line 'vertical) |
| 425 | (let ((divider-width (frame-right-divider-width frame))) | 412 | (let ((divider-width (frame-right-divider-width frame))) |
| 426 | (when (and (or (not (numberp divider-width)) | 413 | (when (and (or (not (numberp divider-width)) |
| 427 | (zerop divider-width)) | 414 | (zerop divider-width)) |
| 428 | (eq (frame-parameter frame 'vertical-scroll-bars) 'left)) | 415 | (eq (frame-parameter frame 'vertical-scroll-bars) 'left)) |
| 429 | (setq window (window-in-direction 'left window t)))))) | 416 | (setq window (window-in-direction 'left window t)))))) |
| 430 | |||
| 431 | (let* ((exitfun nil) | 417 | (let* ((exitfun nil) |
| 432 | (move | 418 | (move |
| 433 | (lambda (event) (interactive "e") | 419 | (lambda (event) (interactive "e") |
| @@ -530,20 +516,405 @@ must be one of the symbols `header', `mode', or `vertical'." | |||
| 530 | t (lambda () (setq track-mouse old-track-mouse))))))) | 516 | t (lambda () (setq track-mouse old-track-mouse))))))) |
| 531 | 517 | ||
| 532 | (defun mouse-drag-mode-line (start-event) | 518 | (defun mouse-drag-mode-line (start-event) |
| 533 | "Change the height of a window by dragging on the mode line." | 519 | "Change the height of a window by dragging on its mode line. |
| 520 | START-EVENT is the starting mouse event of the drag action. | ||
| 521 | |||
| 522 | If the drag happens in a mode line on the bottom of a frame and | ||
| 523 | that frame's `drag-with-mode-line' parameter is non-nil, drag the | ||
| 524 | frame instead." | ||
| 534 | (interactive "e") | 525 | (interactive "e") |
| 535 | (mouse-drag-line start-event 'mode)) | 526 | (let* ((start (event-start start-event)) |
| 527 | (window (posn-window start)) | ||
| 528 | (frame (window-frame window))) | ||
| 529 | (cond | ||
| 530 | ((not (window-live-p window))) | ||
| 531 | ((or (not (window-at-side-p window 'bottom)) | ||
| 532 | ;; Allow resizing the minibuffer window if it's on the | ||
| 533 | ;; same frame as and immediately below `window', and it's | ||
| 534 | ;; either active or `resize-mini-windows' is nil. | ||
| 535 | (let ((minibuffer-window (minibuffer-window frame))) | ||
| 536 | (and (eq (window-frame minibuffer-window) frame) | ||
| 537 | (or (not resize-mini-windows) | ||
| 538 | (eq minibuffer-window | ||
| 539 | (active-minibuffer-window)))))) | ||
| 540 | (mouse-drag-line start-event 'mode)) | ||
| 541 | ((and (frame-parameter frame 'drag-with-mode-line) | ||
| 542 | (window-at-side-p window 'bottom) | ||
| 543 | (let ((minibuffer-window (minibuffer-window frame))) | ||
| 544 | (not (eq (window-frame minibuffer-window) frame)))) | ||
| 545 | ;; Drag frame when the window is on the bottom of its frame and | ||
| 546 | ;; there is no minibuffer window below. | ||
| 547 | (mouse-drag-frame start-event 'move))))) | ||
| 536 | 548 | ||
| 537 | (defun mouse-drag-header-line (start-event) | 549 | (defun mouse-drag-header-line (start-event) |
| 538 | "Change the height of a window by dragging on the header line." | 550 | "Change the height of a window by dragging on its header line. |
| 551 | START-EVENT is the starting mouse event of the drag action. | ||
| 552 | |||
| 553 | If the drag happens in a header line on the top of a frame and | ||
| 554 | that frame's `drag-with-header-line' parameter is non-nil, drag | ||
| 555 | the frame instead." | ||
| 539 | (interactive "e") | 556 | (interactive "e") |
| 540 | (mouse-drag-line start-event 'header)) | 557 | (let* ((start (event-start start-event)) |
| 558 | (window (posn-window start))) | ||
| 559 | (if (and (window-live-p window) | ||
| 560 | (not (window-at-side-p window 'top))) | ||
| 561 | (mouse-drag-line start-event 'header) | ||
| 562 | (let ((frame (window-frame window))) | ||
| 563 | (when (frame-parameter frame 'drag-with-header-line) | ||
| 564 | (mouse-drag-frame start-event 'move)))))) | ||
| 541 | 565 | ||
| 542 | (defun mouse-drag-vertical-line (start-event) | 566 | (defun mouse-drag-vertical-line (start-event) |
| 543 | "Change the width of a window by dragging on the vertical line." | 567 | "Change the width of a window by dragging on a vertical line. |
| 568 | START-EVENT is the starting mouse event of the drag action." | ||
| 544 | (interactive "e") | 569 | (interactive "e") |
| 545 | (mouse-drag-line start-event 'vertical)) | 570 | (mouse-drag-line start-event 'vertical)) |
| 546 | 571 | ||
| 572 | (defun mouse-resize-frame (frame x-diff y-diff &optional x-move y-move) | ||
| 573 | "Helper function for `mouse-drag-frame'." | ||
| 574 | (let* ((frame-x-y (frame-position frame)) | ||
| 575 | (frame-x (car frame-x-y)) | ||
| 576 | (frame-y (cdr frame-x-y)) | ||
| 577 | alist) | ||
| 578 | (if (> x-diff 0) | ||
| 579 | (when x-move | ||
| 580 | (setq x-diff (min x-diff frame-x)) | ||
| 581 | (setq x-move (- frame-x x-diff))) | ||
| 582 | (let* ((min-width (frame-windows-min-size frame t nil t)) | ||
| 583 | (min-diff (max 0 (- (frame-inner-width frame) min-width)))) | ||
| 584 | (setq x-diff (max x-diff (- min-diff))) | ||
| 585 | (when x-move | ||
| 586 | (setq x-move (+ frame-x (- x-diff)))))) | ||
| 587 | |||
| 588 | (if (> y-diff 0) | ||
| 589 | (when y-move | ||
| 590 | (setq y-diff (min y-diff frame-y)) | ||
| 591 | (setq y-move (- frame-y y-diff))) | ||
| 592 | (let* ((min-height (frame-windows-min-size frame nil nil t)) | ||
| 593 | (min-diff (max 0 (- (frame-inner-height frame) min-height)))) | ||
| 594 | (setq y-diff (max y-diff (- min-diff))) | ||
| 595 | (when y-move | ||
| 596 | (setq y-move (+ frame-y (- y-diff)))))) | ||
| 597 | |||
| 598 | (unless (zerop x-diff) | ||
| 599 | (when x-move | ||
| 600 | (push `(left . ,x-move) alist)) | ||
| 601 | (push `(width . (text-pixels . ,(+ (frame-text-width frame) x-diff))) | ||
| 602 | alist)) | ||
| 603 | (unless (zerop y-diff) | ||
| 604 | (when y-move | ||
| 605 | (push `(top . ,y-move) alist)) | ||
| 606 | (push `(height . (text-pixels . ,(+ (frame-text-height frame) y-diff))) | ||
| 607 | alist)) | ||
| 608 | (when alist | ||
| 609 | (modify-frame-parameters frame alist)))) | ||
| 610 | |||
| 611 | (defun mouse-drag-frame (start-event part) | ||
| 612 | "Drag a frame or one of its edges with the mouse. | ||
| 613 | START-EVENT is the starting mouse event of the drag action. Its | ||
| 614 | position window denotes the frame that will be dragged. | ||
| 615 | |||
| 616 | PART specifies the part that has been dragged and must be one of | ||
| 617 | the symbols 'left', 'top', 'right', 'bottom', 'top-left', | ||
| 618 | 'top-right', 'bottom-left', 'bottom-right' to drag an internal | ||
| 619 | border or edge. If PART equals 'move', this means to move the | ||
| 620 | frame with the mouse." | ||
| 621 | ;; Give temporary modes such as isearch a chance to turn off. | ||
| 622 | (run-hooks 'mouse-leave-buffer-hook) | ||
| 623 | (let* ((echo-keystrokes 0) | ||
| 624 | (start (event-start start-event)) | ||
| 625 | (window (posn-window start)) | ||
| 626 | ;; FRAME is the frame to drag. | ||
| 627 | (frame (if (window-live-p window) | ||
| 628 | (window-frame window) | ||
| 629 | window)) | ||
| 630 | (width (frame-native-width frame)) | ||
| 631 | (height (frame-native-height frame)) | ||
| 632 | ;; PARENT is the parent frame of FRAME or, if FRAME is a | ||
| 633 | ;; top-level frame, FRAME's workarea. | ||
| 634 | (parent (frame-parent frame)) | ||
| 635 | (parent-edges | ||
| 636 | (if parent | ||
| 637 | `(0 0 ,(frame-native-width parent) ,(frame-native-height parent)) | ||
| 638 | (let* ((attributes | ||
| 639 | (car (display-monitor-attributes-list))) | ||
| 640 | (workarea (assq 'workarea attributes))) | ||
| 641 | (and workarea | ||
| 642 | `(,(nth 1 workarea) ,(nth 2 workarea) | ||
| 643 | ,(+ (nth 1 workarea) (nth 3 workarea)) | ||
| 644 | ,(+ (nth 2 workarea) (nth 4 workarea))))))) | ||
| 645 | (parent-left (and parent-edges (nth 0 parent-edges))) | ||
| 646 | (parent-top (and parent-edges (nth 1 parent-edges))) | ||
| 647 | (parent-right (and parent-edges (nth 2 parent-edges))) | ||
| 648 | (parent-bottom (and parent-edges (nth 3 parent-edges))) | ||
| 649 | ;; `pos-x' and `pos-y' record the x- and y-coordinates of the | ||
| 650 | ;; last sampled mouse position. Note that we sample absolute | ||
| 651 | ;; mouse positions to avoid that moving the mouse from one | ||
| 652 | ;; frame into another gets into our way. `last-x' and `last-y' | ||
| 653 | ;; records the x- and y-coordinates of the previously sampled | ||
| 654 | ;; position. The differences between `last-x' and `pos-x' as | ||
| 655 | ;; well as `last-y' and `pos-y' determine the amount the mouse | ||
| 656 | ;; has been dragged between the last two samples. | ||
| 657 | pos-x-y pos-x pos-y | ||
| 658 | (last-x-y (mouse-absolute-pixel-position)) | ||
| 659 | (last-x (car last-x-y)) | ||
| 660 | (last-y (cdr last-x-y)) | ||
| 661 | ;; `snap-x' and `snap-y' record the x- and y-coordinates of the | ||
| 662 | ;; mouse position when FRAME snapped. As soon as the | ||
| 663 | ;; difference between `pos-x' and `snap-x' (or `pos-y' and | ||
| 664 | ;; `snap-y') exceeds the value of FRAME's `snap-width' | ||
| 665 | ;; parameter, unsnap FRAME (at the respective side). `snap-x' | ||
| 666 | ;; and `snap-y' nil mean FRAME is curerntly not snapped. | ||
| 667 | snap-x snap-y | ||
| 668 | (exitfun nil) | ||
| 669 | (move | ||
| 670 | (lambda (event) | ||
| 671 | (interactive "e") | ||
| 672 | (when (consp event) | ||
| 673 | (setq pos-x-y (mouse-absolute-pixel-position)) | ||
| 674 | (setq pos-x (car pos-x-y)) | ||
| 675 | (setq pos-y (cdr pos-x-y)) | ||
| 676 | (cond | ||
| 677 | ((eq part 'left) | ||
| 678 | (mouse-resize-frame frame (- last-x pos-x) 0 t)) | ||
| 679 | ((eq part 'top) | ||
| 680 | (mouse-resize-frame frame 0 (- last-y pos-y) nil t)) | ||
| 681 | ((eq part 'right) | ||
| 682 | (mouse-resize-frame frame (- pos-x last-x) 0)) | ||
| 683 | ((eq part 'bottom) | ||
| 684 | (mouse-resize-frame frame 0 (- pos-y last-y))) | ||
| 685 | ((eq part 'top-left) | ||
| 686 | (mouse-resize-frame | ||
| 687 | frame (- last-x pos-x) (- last-y pos-y) t t)) | ||
| 688 | ((eq part 'top-right) | ||
| 689 | (mouse-resize-frame | ||
| 690 | frame (- pos-x last-x) (- last-y pos-y) nil t)) | ||
| 691 | ((eq part 'bottom-left) | ||
| 692 | (mouse-resize-frame | ||
| 693 | frame (- last-x pos-x) (- pos-y last-y) t)) | ||
| 694 | ((eq part 'bottom-right) | ||
| 695 | (mouse-resize-frame | ||
| 696 | frame (- pos-x last-x) (- pos-y last-y))) | ||
| 697 | ((eq part 'move) | ||
| 698 | (let* ((old-position (frame-position frame)) | ||
| 699 | (old-left (car old-position)) | ||
| 700 | (old-top (cdr old-position)) | ||
| 701 | (left (+ old-left (- pos-x last-x))) | ||
| 702 | (top (+ old-top (- pos-y last-y))) | ||
| 703 | right bottom | ||
| 704 | ;; `snap-width' (maybe also a yet to be provided | ||
| 705 | ;; `snap-height') could become floats to handle | ||
| 706 | ;; proportionality wrt PARENT. We don't do any | ||
| 707 | ;; checks on this parameter so far. | ||
| 708 | (snap-width (frame-parameter frame 'snap-width))) | ||
| 709 | ;; Docking and constraining. | ||
| 710 | (when (and (numberp snap-width) parent-edges) | ||
| 711 | (cond | ||
| 712 | ;; Docking at the left parent edge. | ||
| 713 | ((< pos-x last-x) | ||
| 714 | (cond | ||
| 715 | ((and (> left parent-left) | ||
| 716 | (<= (- left parent-left) snap-width)) | ||
| 717 | ;; Snap when the mouse moved leftward and | ||
| 718 | ;; FRAME's left edge would end up within | ||
| 719 | ;; `snap-width' pixels from PARENT's left edge. | ||
| 720 | (setq snap-x pos-x) | ||
| 721 | (setq left parent-left)) | ||
| 722 | ((and (<= left parent-left) | ||
| 723 | (<= (- parent-left left) snap-width) | ||
| 724 | snap-x (<= (- snap-x pos-x) snap-width)) | ||
| 725 | ;; Stay snapped when the mouse moved leftward | ||
| 726 | ;; but not more than `snap-width' pixels from | ||
| 727 | ;; the time FRAME snapped. | ||
| 728 | (setq left parent-left)) | ||
| 729 | (t | ||
| 730 | ;; Unsnap when the mouse moved more than | ||
| 731 | ;; `snap-width' pixels leftward from the time | ||
| 732 | ;; FRAME snapped. | ||
| 733 | (setq snap-x nil)))) | ||
| 734 | ((> pos-x last-x) | ||
| 735 | (setq right (+ left width)) | ||
| 736 | (cond | ||
| 737 | ((and (< right parent-right) | ||
| 738 | (<= (- parent-right right) snap-width)) | ||
| 739 | ;; Snap when the mouse moved rightward and | ||
| 740 | ;; FRAME's right edge would end up within | ||
| 741 | ;; `snap-width' pixels from PARENT's right edge. | ||
| 742 | (setq snap-x pos-x) | ||
| 743 | (setq left (- parent-right width))) | ||
| 744 | ((and (>= right parent-right) | ||
| 745 | (<= (- right parent-right) snap-width) | ||
| 746 | snap-x (<= (- pos-x snap-x) snap-width)) | ||
| 747 | ;; Stay snapped when the mouse moved rightward | ||
| 748 | ;; but not more more than `snap-width' pixels | ||
| 749 | ;; from the time FRAME snapped. | ||
| 750 | (setq left (- parent-right width))) | ||
| 751 | (t | ||
| 752 | ;; Unsnap when the mouse moved rightward more | ||
| 753 | ;; than `snap-width' pixels from the time FRAME | ||
| 754 | ;; snapped. | ||
| 755 | (setq snap-x nil))))) | ||
| 756 | |||
| 757 | (cond | ||
| 758 | ((< pos-y last-y) | ||
| 759 | (cond | ||
| 760 | ((and (> top parent-top) | ||
| 761 | (<= (- top parent-top) snap-width)) | ||
| 762 | ;; Snap when the mouse moved upward and FRAME's | ||
| 763 | ;; top edge would end up within `snap-width' | ||
| 764 | ;; pixels from PARENT's top edge. | ||
| 765 | (setq snap-y pos-y) | ||
| 766 | (setq top parent-top)) | ||
| 767 | ((and (<= top parent-top) | ||
| 768 | (<= (- parent-top top) snap-width) | ||
| 769 | snap-y (<= (- snap-y pos-y) snap-width)) | ||
| 770 | ;; Stay snapped when the mouse moved upward but | ||
| 771 | ;; not more more than `snap-width' pixels from | ||
| 772 | ;; the time FRAME snapped. | ||
| 773 | (setq top parent-top)) | ||
| 774 | (t | ||
| 775 | ;; Unsnap when the mouse moved upward more than | ||
| 776 | ;; `snap-width' pixels from the time FRAME | ||
| 777 | ;; snapped. | ||
| 778 | (setq snap-y nil)))) | ||
| 779 | ((> pos-y last-y) | ||
| 780 | (setq bottom (+ top height)) | ||
| 781 | (cond | ||
| 782 | ((and (< bottom parent-bottom) | ||
| 783 | (<= (- parent-bottom bottom) snap-width)) | ||
| 784 | ;; Snap when the mouse moved downward and | ||
| 785 | ;; FRAME's bottom edge would end up within | ||
| 786 | ;; `snap-width' pixels from PARENT's bottom | ||
| 787 | ;; edge. | ||
| 788 | (setq snap-y pos-y) | ||
| 789 | (setq top (- parent-bottom height))) | ||
| 790 | ((and (>= bottom parent-bottom) | ||
| 791 | (<= (- bottom parent-bottom) snap-width) | ||
| 792 | snap-y (<= (- pos-y snap-y) snap-width)) | ||
| 793 | ;; Stay snapped when the mouse moved downward | ||
| 794 | ;; but not more more than `snap-width' pixels | ||
| 795 | ;; from the time FRAME snapped. | ||
| 796 | (setq top (- parent-bottom height))) | ||
| 797 | (t | ||
| 798 | ;; Unsnap when the mouse moved downward more | ||
| 799 | ;; than `snap-width' pixels from the time FRAME | ||
| 800 | ;; snapped. | ||
| 801 | (setq snap-y nil)))))) | ||
| 802 | |||
| 803 | ;; If requested, constrain FRAME's draggable areas to | ||
| 804 | ;; PARENT's edges. The `top-visible' parameter should | ||
| 805 | ;; be set when FRAME has a draggable header-line. If | ||
| 806 | ;; set to a number, it ascertains that the top of | ||
| 807 | ;; FRAME is always constrained to the top of PARENT | ||
| 808 | ;; and that at least as many pixels of FRAME as | ||
| 809 | ;; specified by that number are visible on each of the | ||
| 810 | ;; three remaining sides of PARENT. | ||
| 811 | ;; | ||
| 812 | ;; The `bottom-visible' parameter should be set when | ||
| 813 | ;; FRAME has a draggable mode-line. If set to a | ||
| 814 | ;; number, it ascertains that the bottom of FRAME is | ||
| 815 | ;; always constrained to the bottom of PARENT and that | ||
| 816 | ;; at least as many pixels of FRAME as specified by | ||
| 817 | ;; that number are visible on each of the three | ||
| 818 | ;; remaining sides of PARENT. | ||
| 819 | (let ((par (frame-parameter frame 'top-visible)) | ||
| 820 | bottom-visible) | ||
| 821 | (unless par | ||
| 822 | (setq par (frame-parameter frame 'bottom-visible)) | ||
| 823 | (setq bottom-visible t)) | ||
| 824 | (when (and (numberp par) parent-edges) | ||
| 825 | (setq left | ||
| 826 | (max (min (- parent-right par) left) | ||
| 827 | (+ (- parent-left width) par))) | ||
| 828 | (setq top | ||
| 829 | (if bottom-visible | ||
| 830 | (min (max top (- parent-top (- height par))) | ||
| 831 | (- parent-bottom height)) | ||
| 832 | (min (max top parent-top) | ||
| 833 | (- parent-bottom par)))))) | ||
| 834 | |||
| 835 | ;; Use `modify-frame-parameters' since `left' and | ||
| 836 | ;; `top' may want to move FRAME out of its PARENT. | ||
| 837 | (modify-frame-parameters | ||
| 838 | frame | ||
| 839 | `((left . (+ ,left)) (top . (+ ,top))))))) | ||
| 840 | (setq last-x pos-x) | ||
| 841 | (setq last-y pos-y)))) | ||
| 842 | (old-track-mouse track-mouse)) | ||
| 843 | ;; Start tracking. The special value 'dragging' signals the | ||
| 844 | ;; display engine to freeze the mouse pointer shape for as long | ||
| 845 | ;; as we drag. | ||
| 846 | (setq track-mouse 'dragging) | ||
| 847 | ;; Loop reading events and sampling the position of the mouse. | ||
| 848 | (setq exitfun | ||
| 849 | (set-transient-map | ||
| 850 | (let ((map (make-sparse-keymap))) | ||
| 851 | (define-key map [switch-frame] #'ignore) | ||
| 852 | (define-key map [select-window] #'ignore) | ||
| 853 | (define-key map [scroll-bar-movement] #'ignore) | ||
| 854 | (define-key map [mouse-movement] move) | ||
| 855 | ;; Swallow drag-mouse-1 events to avoid selecting some other window. | ||
| 856 | (define-key map [drag-mouse-1] | ||
| 857 | (lambda () (interactive) (funcall exitfun))) | ||
| 858 | ;; Some of the events will of course end up looked up | ||
| 859 | ;; with a mode-line, header-line or vertical-line prefix ... | ||
| 860 | (define-key map [mode-line] map) | ||
| 861 | (define-key map [header-line] map) | ||
| 862 | (define-key map [vertical-line] map) | ||
| 863 | ;; ... and some maybe even with a right- or bottom-divider | ||
| 864 | ;; prefix. | ||
| 865 | (define-key map [right-divider] map) | ||
| 866 | (define-key map [bottom-divider] map) | ||
| 867 | map) | ||
| 868 | t (lambda () (setq track-mouse old-track-mouse)))))) | ||
| 869 | |||
| 870 | (defun mouse-drag-left-edge (start-event) | ||
| 871 | "Drag left edge of a frame with the mouse. | ||
| 872 | START-EVENT is the starting mouse event of the drag action." | ||
| 873 | (interactive "e") | ||
| 874 | (mouse-drag-frame start-event 'left)) | ||
| 875 | |||
| 876 | (defun mouse-drag-top-left-corner (start-event) | ||
| 877 | "Drag top left corner of a frame with the mouse. | ||
| 878 | START-EVENT is the starting mouse event of the drag action." | ||
| 879 | (interactive "e") | ||
| 880 | (mouse-drag-frame start-event 'top-left)) | ||
| 881 | |||
| 882 | (defun mouse-drag-top-edge (start-event) | ||
| 883 | "Drag top edge of a frame with the mouse. | ||
| 884 | START-EVENT is the starting mouse event of the drag action." | ||
| 885 | (interactive "e") | ||
| 886 | (mouse-drag-frame start-event 'top)) | ||
| 887 | |||
| 888 | (defun mouse-drag-top-right-corner (start-event) | ||
| 889 | "Drag top right corner of a frame with the mouse. | ||
| 890 | START-EVENT is the starting mouse event of the drag action." | ||
| 891 | (interactive "e") | ||
| 892 | (mouse-drag-frame start-event 'top-right)) | ||
| 893 | |||
| 894 | (defun mouse-drag-right-edge (start-event) | ||
| 895 | "Drag right edge of a frame with the mouse. | ||
| 896 | START-EVENT is the starting mouse event of the drag action." | ||
| 897 | (interactive "e") | ||
| 898 | (mouse-drag-frame start-event 'right)) | ||
| 899 | |||
| 900 | (defun mouse-drag-bottom-right-corner (start-event) | ||
| 901 | "Drag bottom right corner of a frame with the mouse. | ||
| 902 | START-EVENT is the starting mouse event of the drag action." | ||
| 903 | (interactive "e") | ||
| 904 | (mouse-drag-frame start-event 'bottom-right)) | ||
| 905 | |||
| 906 | (defun mouse-drag-bottom-edge (start-event) | ||
| 907 | "Drag bottom edge of a frame with the mouse. | ||
| 908 | START-EVENT is the starting mouse event of the drag action." | ||
| 909 | (interactive "e") | ||
| 910 | (mouse-drag-frame start-event 'bottom)) | ||
| 911 | |||
| 912 | (defun mouse-drag-bottom-left-corner (start-event) | ||
| 913 | "Drag bottom left corner of a frame with the mouse. | ||
| 914 | START-EVENT is the starting mouse event of the drag action." | ||
| 915 | (interactive "e") | ||
| 916 | (mouse-drag-frame start-event 'bottom-left)) | ||
| 917 | |||
| 547 | (defcustom mouse-select-region-move-to-beginning nil | 918 | (defcustom mouse-select-region-move-to-beginning nil |
| 548 | "Effect of selecting a region extending backward from double click. | 919 | "Effect of selecting a region extending backward from double click. |
| 549 | Nil means keep point at the position clicked (region end); | 920 | Nil means keep point at the position clicked (region end); |
| @@ -2078,6 +2449,22 @@ is copied instead of being cut." | |||
| 2078 | (global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line) | 2449 | (global-set-key [bottom-divider down-mouse-1] 'mouse-drag-mode-line) |
| 2079 | (global-set-key [bottom-divider mouse-1] 'ignore) | 2450 | (global-set-key [bottom-divider mouse-1] 'ignore) |
| 2080 | (global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally) | 2451 | (global-set-key [bottom-divider C-mouse-2] 'mouse-split-window-horizontally) |
| 2452 | (global-set-key [left-edge down-mouse-1] 'mouse-drag-left-edge) | ||
| 2453 | (global-set-key [left-edge mouse-1] 'ignore) | ||
| 2454 | (global-set-key [top-left-corner down-mouse-1] 'mouse-drag-top-left-corner) | ||
| 2455 | (global-set-key [top-left-corner mouse-1] 'ignore) | ||
| 2456 | (global-set-key [top-edge down-mouse-1] 'mouse-drag-top-edge) | ||
| 2457 | (global-set-key [top-edge mouse-1] 'ignore) | ||
| 2458 | (global-set-key [top-right-corner down-mouse-1] 'mouse-drag-top-right-corner) | ||
| 2459 | (global-set-key [top-right-corner mouse-1] 'ignore) | ||
| 2460 | (global-set-key [right-edge down-mouse-1] 'mouse-drag-right-edge) | ||
| 2461 | (global-set-key [right-edge mouse-1] 'ignore) | ||
| 2462 | (global-set-key [bottom-right-corner down-mouse-1] 'mouse-drag-bottom-right-corner) | ||
| 2463 | (global-set-key [bottom-right-corner mouse-1] 'ignore) | ||
| 2464 | (global-set-key [bottom-edge down-mouse-1] 'mouse-drag-bottom-edge) | ||
| 2465 | (global-set-key [bottom-edge mouse-1] 'ignore) | ||
| 2466 | (global-set-key [bottom-left-corner down-mouse-1] 'mouse-drag-bottom-left-corner) | ||
| 2467 | (global-set-key [bottom-left-corner mouse-1] 'ignore) | ||
| 2081 | 2468 | ||
| 2082 | (provide 'mouse) | 2469 | (provide 'mouse) |
| 2083 | 2470 | ||
diff --git a/lisp/net/eww.el b/lisp/net/eww.el index fe316579142..2fc36e180ee 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el | |||
| @@ -312,11 +312,19 @@ word(s) will be searched for via `eww-search-prefix'." | |||
| 312 | (expand-file-name file)))) | 312 | (expand-file-name file)))) |
| 313 | 313 | ||
| 314 | ;;;###autoload | 314 | ;;;###autoload |
| 315 | (defun eww-search-words (&optional beg end) | 315 | (defun eww-search-words () |
| 316 | "Search the web for the text between BEG and END. | 316 | "Search the web for the text between BEG and END. |
| 317 | See the `eww-search-prefix' variable for the search engine used." | 317 | If region is active (and not whitespace), search the web for |
| 318 | (interactive "r") | 318 | the text between BEG and END. Else, prompt the user for a search |
| 319 | (eww (buffer-substring beg end))) | 319 | string. See the `eww-search-prefix' variable for the search |
| 320 | engine used." | ||
| 321 | (interactive) | ||
| 322 | (if (use-region-p) | ||
| 323 | (let ((region-string (buffer-substring (region-beginning) (region-end)))) | ||
| 324 | (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) | ||
| 325 | (eww region-string) | ||
| 326 | (call-interactively 'eww))) | ||
| 327 | (call-interactively 'eww))) | ||
| 320 | 328 | ||
| 321 | (defun eww-open-in-new-buffer () | 329 | (defun eww-open-in-new-buffer () |
| 322 | "Fetch link at point in a new EWW buffer." | 330 | "Fetch link at point in a new EWW buffer." |
diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 2a6b3960c46..4d4e8a809e1 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el | |||
| @@ -185,8 +185,8 @@ and other things: | |||
| 185 | (define-key map [follow-link] 'mouse-face) | 185 | (define-key map [follow-link] 'mouse-face) |
| 186 | (define-key map [mouse-2] 'shr-browse-url) | 186 | (define-key map [mouse-2] 'shr-browse-url) |
| 187 | (define-key map "I" 'shr-insert-image) | 187 | (define-key map "I" 'shr-insert-image) |
| 188 | (define-key map "w" 'shr-copy-url) | 188 | (define-key map "w" 'shr-maybe-probe-and-copy-url) |
| 189 | (define-key map "u" 'shr-copy-url) | 189 | (define-key map "u" 'shr-maybe-probe-and-copy-url) |
| 190 | (define-key map "v" 'shr-browse-url) | 190 | (define-key map "v" 'shr-browse-url) |
| 191 | (define-key map "O" 'shr-save-contents) | 191 | (define-key map "O" 'shr-save-contents) |
| 192 | (define-key map "\r" 'shr-browse-url) | 192 | (define-key map "\r" 'shr-browse-url) |
| @@ -290,43 +290,59 @@ DOM should be a parse tree as generated by | |||
| 290 | (forward-line 1) | 290 | (forward-line 1) |
| 291 | (delete-region (point) (point-max)))))) | 291 | (delete-region (point) (point-max)))))) |
| 292 | 292 | ||
| 293 | (defun shr-copy-url (&optional image-url) | 293 | (defun shr-url-at-point (image-url) |
| 294 | "Return the URL under point as a string. | ||
| 295 | If IMAGE-URL is non-nil, or there is no link under point, but | ||
| 296 | there is an image under point then copy the URL of the image | ||
| 297 | under point instead." | ||
| 298 | (if image-url | ||
| 299 | (get-text-property (point) 'image-url) | ||
| 300 | (or (get-text-property (point) 'shr-url) | ||
| 301 | (get-text-property (point) 'image-url)))) | ||
| 302 | |||
| 303 | (defun shr-copy-url (url) | ||
| 294 | "Copy the URL under point to the kill ring. | 304 | "Copy the URL under point to the kill ring. |
| 295 | If IMAGE-URL (the prefix) is non-nil, or there is no link under | 305 | If IMAGE-URL (the prefix) is non-nil, or there is no link under |
| 296 | point, but there is an image under point then copy the URL of the | 306 | point, but there is an image under point then copy the URL of the |
| 297 | image under point instead. | 307 | image under point instead." |
| 298 | If called twice, then try to fetch the URL and see whether it | 308 | (interactive (list (shr-url-at-point current-prefix-arg))) |
| 299 | redirects somewhere else." | 309 | (if (not url) |
| 310 | (message "No URL under point") | ||
| 311 | (setq url (url-encode-url url)) | ||
| 312 | (kill-new url) | ||
| 313 | (message "Copied %s" url))) | ||
| 314 | |||
| 315 | (defun shr-probe-url (url cont) | ||
| 316 | "Pass URL's redirect destination to CONT, if it has one. | ||
| 317 | CONT should be a function of one argument, the redirect | ||
| 318 | destination URL. If URL is not redirected, then CONT is never | ||
| 319 | called." | ||
| 300 | (interactive "P") | 320 | (interactive "P") |
| 301 | (let ((url (if image-url | 321 | (url-retrieve |
| 302 | (get-text-property (point) 'image-url) | 322 | url (lambda (a) |
| 303 | (or (get-text-property (point) 'shr-url) | 323 | (pcase a |
| 304 | (get-text-property (point) 'image-url))))) | 324 | (`(:redirect ,destination . ,_) |
| 305 | (cond | 325 | ;; Remove common tracking junk from the URL. |
| 306 | ((not url) | 326 | (funcall cont (replace-regexp-in-string |
| 307 | (message "No URL under point")) | 327 | ".utm_.*" "" destination))))) |
| 308 | ;; Resolve redirected URLs. | 328 | nil t)) |
| 309 | ((equal url (car kill-ring)) | 329 | |
| 310 | (url-retrieve | 330 | (defun shr-probe-and-copy-url (url) |
| 311 | url | 331 | "Copy the URL under point to the kill ring. |
| 312 | (lambda (a) | 332 | Like `shr-copy-url', but additionally fetch URL and use its |
| 313 | (when (and (consp a) | 333 | redirection destination if it has one." |
| 314 | (eq (car a) :redirect)) | 334 | (interactive (list (shr-url-at-point current-prefix-arg))) |
| 315 | (with-temp-buffer | 335 | (if url (shr-probe-url url #'shr-copy-url) |
| 316 | (insert (cadr a)) | 336 | (shr-copy-url url))) |
| 317 | (goto-char (point-min)) | 337 | |
| 318 | ;; Remove common tracking junk from the URL. | 338 | (defun shr-maybe-probe-and-copy-url (url) |
| 319 | (when (re-search-forward ".utm_.*" nil t) | 339 | "Copy the URL under point to the kill ring. |
| 320 | (replace-match "" t t)) | 340 | If the URL is already at the front of the kill ring act like |
| 321 | (message "Copied %s" (buffer-string)) | 341 | `shr-probe-and-copy-url', otherwise like `shr-copy-url'." |
| 322 | (copy-region-as-kill (point-min) (point-max))))) | 342 | (interactive (list (shr-url-at-point current-prefix-arg))) |
| 323 | nil t)) | 343 | (if (equal url (car kill-ring)) |
| 324 | ;; Copy the URL to the kill ring. | 344 | (shr-probe-and-copy-url url) |
| 325 | (t | 345 | (shr-copy-url url))) |
| 326 | (with-temp-buffer | ||
| 327 | (insert (url-encode-url url)) | ||
| 328 | (copy-region-as-kill (point-min) (point-max)) | ||
| 329 | (message "Copied %s" (buffer-string))))))) | ||
| 330 | 346 | ||
| 331 | (defun shr-next-link () | 347 | (defun shr-next-link () |
| 332 | "Skip to the next link." | 348 | "Skip to the next link." |
| @@ -512,6 +528,7 @@ size, and full-buffer size." | |||
| 512 | (* (frame-char-width) 2) | 528 | (* (frame-char-width) 2) |
| 513 | 0)))) | 529 | 0)))) |
| 514 | (shr-insert text) | 530 | (shr-insert text) |
| 531 | (shr-fill-lines (point-min) (point-max)) | ||
| 515 | (buffer-string))))) | 532 | (buffer-string))))) |
| 516 | 533 | ||
| 517 | (define-inline shr-char-breakable-p (char) | 534 | (define-inline shr-char-breakable-p (char) |
diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 23aa90186a6..346979000f5 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el | |||
| @@ -72,7 +72,7 @@ It is used for TCP/IP devices." | |||
| 72 | (defconst tramp-adb-ls-toolbox-regexp | 72 | (defconst tramp-adb-ls-toolbox-regexp |
| 73 | (concat | 73 | (concat |
| 74 | "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions | 74 | "^[[:space:]]*\\([-[:alpha:]]+\\)" ; \1 permissions |
| 75 | "\\(?:[[:space:]][[:digit:]]+\\)?" ; links (Android 7/ToolBox) | 75 | "\\(?:[[:space:]]+[[:digit:]]+\\)?" ; links (Android 7/toybox) |
| 76 | "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username | 76 | "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username |
| 77 | "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group | 77 | "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group |
| 78 | "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size | 78 | "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size |
| @@ -411,15 +411,17 @@ pass to the OPERATION." | |||
| 411 | (tramp-adb-get-ls-command v) | 411 | (tramp-adb-get-ls-command v) |
| 412 | (tramp-shell-quote-argument localname))) | 412 | (tramp-shell-quote-argument localname))) |
| 413 | ;; We insert also filename/. and filename/.., because "ls" doesn't. | 413 | ;; We insert also filename/. and filename/.., because "ls" doesn't. |
| 414 | (narrow-to-region (point) (point)) | 414 | ;; Looks like it does include them in toybox, since Android 6. |
| 415 | (tramp-adb-send-command | 415 | (unless (re-search-backward "\\.$" nil t) |
| 416 | v (format "%s -d -a -l %s %s" | 416 | (narrow-to-region (point-max) (point-max)) |
| 417 | (tramp-adb-get-ls-command v) | 417 | (tramp-adb-send-command |
| 418 | (tramp-shell-quote-argument | 418 | v (format "%s -d -a -l %s %s" |
| 419 | (concat (file-name-as-directory localname) ".")) | 419 | (tramp-adb-get-ls-command v) |
| 420 | (tramp-shell-quote-argument | 420 | (tramp-shell-quote-argument |
| 421 | (concat (file-name-as-directory localname) "..")))) | 421 | (concat (file-name-as-directory localname) ".")) |
| 422 | (widen)) | 422 | (tramp-shell-quote-argument |
| 423 | (concat (file-name-as-directory localname) "..")))) | ||
| 424 | (widen))) | ||
| 423 | (tramp-adb-sh-fix-ls-output) | 425 | (tramp-adb-sh-fix-ls-output) |
| 424 | (let ((result (tramp-do-parse-file-attributes-with-ls | 426 | (let ((result (tramp-do-parse-file-attributes-with-ls |
| 425 | v (or id-format 'integer)))) | 427 | v (or id-format 'integer)))) |
| @@ -443,11 +445,12 @@ pass to the OPERATION." | |||
| 443 | (with-tramp-connection-property vec "ls" | 445 | (with-tramp-connection-property vec "ls" |
| 444 | (tramp-message vec 5 "Finding a suitable `ls' command") | 446 | (tramp-message vec 5 "Finding a suitable `ls' command") |
| 445 | (cond | 447 | (cond |
| 446 | ;; Can't disable coloring explicitly for toybox ls command | 448 | ;; Can't disable coloring explicitly for toybox ls command. We |
| 447 | ((tramp-adb-send-command-and-check vec "toybox") "ls") | 449 | ;; must force "ls" to print just one column. |
| 450 | ((tramp-adb-send-command-and-check vec "toybox") "env COLUMNS=1 ls") | ||
| 448 | ;; On CyanogenMod based system BusyBox is used and "ls" output | 451 | ;; On CyanogenMod based system BusyBox is used and "ls" output |
| 449 | ;; coloring is enabled by default. So we try to disable it | 452 | ;; coloring is enabled by default. So we try to disable it when |
| 450 | ;; when possible. | 453 | ;; possible. |
| 451 | ((tramp-adb-send-command-and-check vec "ls --color=never -al /dev/null") | 454 | ((tramp-adb-send-command-and-check vec "ls --color=never -al /dev/null") |
| 452 | "ls --color=never") | 455 | "ls --color=never") |
| 453 | (t "ls")))) | 456 | (t "ls")))) |
| @@ -569,13 +572,17 @@ Emacs dired can't find files." | |||
| 569 | (file-name-as-directory f) | 572 | (file-name-as-directory f) |
| 570 | f)) | 573 | f)) |
| 571 | (with-current-buffer (tramp-get-buffer v) | 574 | (with-current-buffer (tramp-get-buffer v) |
| 572 | (append | 575 | (delete-dups |
| 573 | '("." "..") | 576 | (append |
| 574 | (delq | 577 | ;; In older Android versions, "." and ".." are not |
| 575 | nil | 578 | ;; included. In newer versions (toybox, since Android |
| 576 | (mapcar | 579 | ;; 6) they are. We fix this by `delete-dups'. |
| 577 | (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) | 580 | '("." "..") |
| 578 | (split-string (buffer-string) "\n"))))))))))) | 581 | (delq |
| 582 | nil | ||
| 583 | (mapcar | ||
| 584 | (lambda (l) (and (not (string-match "^[[:space:]]*$" l)) l)) | ||
| 585 | (split-string (buffer-string) "\n")))))))))))) | ||
| 579 | 586 | ||
| 580 | (defun tramp-adb-handle-file-local-copy (filename) | 587 | (defun tramp-adb-handle-file-local-copy (filename) |
| 581 | "Like `file-local-copy' for Tramp files." | 588 | "Like `file-local-copy' for Tramp files." |
diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index c998df814c1..b2df4d6324b 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el | |||
| @@ -252,7 +252,8 @@ If NAME is a remote file name, the local part of NAME is unquoted." | |||
| 252 | (eval-after-load 'tramp | 252 | (eval-after-load 'tramp |
| 253 | '(unless | 253 | '(unless |
| 254 | (memq tramp-syntax (tramp-compat-funcall (quote tramp-syntax-values))) | 254 | (memq tramp-syntax (tramp-compat-funcall (quote tramp-syntax-values))) |
| 255 | (tramp-change-syntax (tramp-compat-tramp-syntax)))) | 255 | (tramp-compat-funcall |
| 256 | (quote tramp-change-syntax) (tramp-compat-tramp-syntax)))) | ||
| 256 | 257 | ||
| 257 | (provide 'tramp-compat) | 258 | (provide 'tramp-compat) |
| 258 | 259 | ||
diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index f7b457ebf04..94518d0d359 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el | |||
| @@ -3500,21 +3500,10 @@ the result will be a local, non-Tramp, file name." | |||
| 3500 | (defun tramp-sh-file-name-handler (operation &rest args) | 3500 | (defun tramp-sh-file-name-handler (operation &rest args) |
| 3501 | "Invoke remote-shell Tramp file name handler. | 3501 | "Invoke remote-shell Tramp file name handler. |
| 3502 | Fall back to normal file name handler if no Tramp handler exists." | 3502 | Fall back to normal file name handler if no Tramp handler exists." |
| 3503 | (when (and tramp-locked (not tramp-locker)) | 3503 | (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) |
| 3504 | (setq tramp-locked nil) | 3504 | (if fn |
| 3505 | (tramp-error | 3505 | (save-match-data (apply (cdr fn) args)) |
| 3506 | (car-safe tramp-current-connection) 'file-error | 3506 | (tramp-run-real-handler operation args)))) |
| 3507 | "Forbidden reentrant call of Tramp")) | ||
| 3508 | (let ((tl tramp-locked)) | ||
| 3509 | (setq tramp-locked t) | ||
| 3510 | (unwind-protect | ||
| 3511 | (let ((tramp-locker t)) | ||
| 3512 | (save-match-data | ||
| 3513 | (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) | ||
| 3514 | (if fn | ||
| 3515 | (apply (cdr fn) args) | ||
| 3516 | (tramp-run-real-handler operation args))))) | ||
| 3517 | (setq tramp-locked tl)))) | ||
| 3518 | 3507 | ||
| 3519 | ;; This must be the last entry, because `identity' always matches. | 3508 | ;; This must be the last entry, because `identity' always matches. |
| 3520 | ;;;###tramp-autoload | 3509 | ;;;###tramp-autoload |
diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 8d81ac64aa2..9c327c410a7 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el | |||
| @@ -2053,6 +2053,33 @@ ARGS are the arguments OPERATION has been called with." | |||
| 2053 | `(let ((debug-on-error tramp-debug-on-error)) | 2053 | `(let ((debug-on-error tramp-debug-on-error)) |
| 2054 | (condition-case-unless-debug ,var ,bodyform ,@handlers))) | 2054 | (condition-case-unless-debug ,var ,bodyform ,@handlers))) |
| 2055 | 2055 | ||
| 2056 | ;; In Emacs, there is some concurrency due to timers. If a timer | ||
| 2057 | ;; interrupts Tramp and wishes to use the same connection buffer as | ||
| 2058 | ;; the "main" Emacs, then garbage might occur in the connection | ||
| 2059 | ;; buffer. Therefore, we need to make sure that a timer does not use | ||
| 2060 | ;; the same connection buffer as the "main" Emacs. We implement a | ||
| 2061 | ;; cheap global lock, instead of locking each connection buffer | ||
| 2062 | ;; separately. The global lock is based on two variables, | ||
| 2063 | ;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true | ||
| 2064 | ;; (with setq) to indicate a lock. But Tramp also calls itself during | ||
| 2065 | ;; processing of a single file operation, so we need to allow | ||
| 2066 | ;; recursive calls. That's where the `tramp-locker' variable comes in | ||
| 2067 | ;; -- it is let-bound to t during the execution of the current | ||
| 2068 | ;; handler. So if `tramp-locked' is t and `tramp-locker' is also t, | ||
| 2069 | ;; then we should just proceed because we have been called | ||
| 2070 | ;; recursively. But if `tramp-locker' is nil, then we are a timer | ||
| 2071 | ;; interrupting the "main" Emacs, and then we signal an error. | ||
| 2072 | |||
| 2073 | (defvar tramp-locked nil | ||
| 2074 | "If non-nil, then Tramp is currently busy. | ||
| 2075 | Together with `tramp-locker', this implements a locking mechanism | ||
| 2076 | preventing reentrant calls of Tramp.") | ||
| 2077 | |||
| 2078 | (defvar tramp-locker nil | ||
| 2079 | "If non-nil, then a caller has locked Tramp. | ||
| 2080 | Together with `tramp-locked', this implements a locking mechanism | ||
| 2081 | preventing reentrant calls of Tramp.") | ||
| 2082 | |||
| 2056 | ;; Main function. | 2083 | ;; Main function. |
| 2057 | (defun tramp-file-name-handler (operation &rest args) | 2084 | (defun tramp-file-name-handler (operation &rest args) |
| 2058 | "Invoke Tramp file name handler. | 2085 | "Invoke Tramp file name handler. |
| @@ -2090,7 +2117,20 @@ Falls back to normal file name handler if no Tramp file name handler exists." | |||
| 2090 | (setq result | 2117 | (setq result |
| 2091 | (catch 'non-essential | 2118 | (catch 'non-essential |
| 2092 | (catch 'suppress | 2119 | (catch 'suppress |
| 2093 | (apply foreign operation args)))) | 2120 | (when (and tramp-locked (not tramp-locker)) |
| 2121 | (setq tramp-locked nil) | ||
| 2122 | (tramp-error | ||
| 2123 | (car-safe tramp-current-connection) | ||
| 2124 | 'file-error | ||
| 2125 | "Forbidden reentrant call of Tramp")) | ||
| 2126 | (let ((tl tramp-locked)) | ||
| 2127 | (setq tramp-locked t) | ||
| 2128 | (unwind-protect | ||
| 2129 | (let ((tramp-locker t)) | ||
| 2130 | (apply foreign operation args)) | ||
| 2131 | ;; Give timers a chance. | ||
| 2132 | (unless (setq tramp-locked tl) | ||
| 2133 | (sit-for 0.001 'nodisp))))))) | ||
| 2094 | (cond | 2134 | (cond |
| 2095 | ((eq result 'non-essential) | 2135 | ((eq result 'non-essential) |
| 2096 | (tramp-message | 2136 | (tramp-message |
| @@ -2145,33 +2185,6 @@ Falls back to normal file name handler if no Tramp file name handler exists." | |||
| 2145 | ;; we don't do anything. | 2185 | ;; we don't do anything. |
| 2146 | (tramp-run-real-handler operation args)))) | 2186 | (tramp-run-real-handler operation args)))) |
| 2147 | 2187 | ||
| 2148 | ;; In Emacs, there is some concurrency due to timers. If a timer | ||
| 2149 | ;; interrupts Tramp and wishes to use the same connection buffer as | ||
| 2150 | ;; the "main" Emacs, then garbage might occur in the connection | ||
| 2151 | ;; buffer. Therefore, we need to make sure that a timer does not use | ||
| 2152 | ;; the same connection buffer as the "main" Emacs. We implement a | ||
| 2153 | ;; cheap global lock, instead of locking each connection buffer | ||
| 2154 | ;; separately. The global lock is based on two variables, | ||
| 2155 | ;; `tramp-locked' and `tramp-locker'. `tramp-locked' is set to true | ||
| 2156 | ;; (with setq) to indicate a lock. But Tramp also calls itself during | ||
| 2157 | ;; processing of a single file operation, so we need to allow | ||
| 2158 | ;; recursive calls. That's where the `tramp-locker' variable comes in | ||
| 2159 | ;; -- it is let-bound to t during the execution of the current | ||
| 2160 | ;; handler. So if `tramp-locked' is t and `tramp-locker' is also t, | ||
| 2161 | ;; then we should just proceed because we have been called | ||
| 2162 | ;; recursively. But if `tramp-locker' is nil, then we are a timer | ||
| 2163 | ;; interrupting the "main" Emacs, and then we signal an error. | ||
| 2164 | |||
| 2165 | (defvar tramp-locked nil | ||
| 2166 | "If non-nil, then Tramp is currently busy. | ||
| 2167 | Together with `tramp-locker', this implements a locking mechanism | ||
| 2168 | preventing reentrant calls of Tramp.") | ||
| 2169 | |||
| 2170 | (defvar tramp-locker nil | ||
| 2171 | "If non-nil, then a caller has locked Tramp. | ||
| 2172 | Together with `tramp-locked', this implements a locking mechanism | ||
| 2173 | preventing reentrant calls of Tramp.") | ||
| 2174 | |||
| 2175 | ;;;###autoload | 2188 | ;;;###autoload |
| 2176 | (defun tramp-completion-file-name-handler (operation &rest args) | 2189 | (defun tramp-completion-file-name-handler (operation &rest args) |
| 2177 | "Invoke Tramp file name completion handler. | 2190 | "Invoke Tramp file name completion handler. |
| @@ -3631,31 +3644,17 @@ connection buffer." | |||
| 3631 | "Like `accept-process-output' for Tramp processes. | 3644 | "Like `accept-process-output' for Tramp processes. |
| 3632 | This is needed in order to hide `last-coding-system-used', which is set | 3645 | This is needed in order to hide `last-coding-system-used', which is set |
| 3633 | for process communication also." | 3646 | for process communication also." |
| 3634 | ;; FIXME: There are problems, when an asynchronous process runs in | ||
| 3635 | ;; parallel, and also timers are active. See | ||
| 3636 | ;; <http://lists.gnu.org/archive/html/tramp-devel/2017-01/msg00010.html>. | ||
| 3637 | (when (and timer-event-last | ||
| 3638 | (string-prefix-p "*tramp/" (process-name proc)) | ||
| 3639 | (let (result) | ||
| 3640 | (maphash | ||
| 3641 | (lambda (key _value) | ||
| 3642 | (and (processp key) | ||
| 3643 | (not (string-prefix-p "*tramp/" (process-name key))) | ||
| 3644 | (process-live-p key) | ||
| 3645 | (setq result t))) | ||
| 3646 | tramp-cache-data) | ||
| 3647 | result)) | ||
| 3648 | (sit-for 0.01 'nodisp)) | ||
| 3649 | (with-current-buffer (process-buffer proc) | 3647 | (with-current-buffer (process-buffer proc) |
| 3650 | (let (buffer-read-only last-coding-system-used) | 3648 | (let (buffer-read-only last-coding-system-used) |
| 3651 | ;; Under Windows XP, accept-process-output doesn't return | 3649 | ;; Under Windows XP, `accept-process-output' doesn't return |
| 3652 | ;; sometimes. So we add an additional timeout. JUST-THIS-ONE | 3650 | ;; sometimes. So we add an additional timeout. JUST-THIS-ONE |
| 3653 | ;; is set due to Bug#12145. | 3651 | ;; is set due to Bug#12145. It is an integer, in order to avoid |
| 3652 | ;; running timers as well. | ||
| 3654 | (tramp-message | 3653 | (tramp-message |
| 3655 | proc 10 "%s %s %s\n%s" | 3654 | proc 10 "%s %s %s\n%s" |
| 3656 | proc (process-status proc) | 3655 | proc (process-status proc) |
| 3657 | (with-timeout (timeout) | 3656 | (with-timeout (timeout) |
| 3658 | (accept-process-output proc timeout nil t)) | 3657 | (accept-process-output proc timeout nil 0)) |
| 3659 | (buffer-string))))) | 3658 | (buffer-string))))) |
| 3660 | 3659 | ||
| 3661 | (defun tramp-check-for-regexp (proc regexp) | 3660 | (defun tramp-check-for-regexp (proc regexp) |
diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index 387a3c8bb36..4be487e1f4f 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el | |||
| @@ -7,7 +7,7 @@ | |||
| 7 | ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> | 7 | ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> |
| 8 | ;; Keywords: comm, processes | 8 | ;; Keywords: comm, processes |
| 9 | ;; Package: tramp | 9 | ;; Package: tramp |
| 10 | ;; Version: 2.3.2-pre | 10 | ;; Version: 2.3.2 |
| 11 | 11 | ||
| 12 | ;; This file is part of GNU Emacs. | 12 | ;; This file is part of GNU Emacs. |
| 13 | 13 | ||
| @@ -33,7 +33,7 @@ | |||
| 33 | ;; should be changed only there. | 33 | ;; should be changed only there. |
| 34 | 34 | ||
| 35 | ;;;###tramp-autoload | 35 | ;;;###tramp-autoload |
| 36 | (defconst tramp-version "2.3.2-pre" | 36 | (defconst tramp-version "2.3.2" |
| 37 | "This version of Tramp.") | 37 | "This version of Tramp.") |
| 38 | 38 | ||
| 39 | ;;;###tramp-autoload | 39 | ;;;###tramp-autoload |
| @@ -55,7 +55,7 @@ | |||
| 55 | ;; Check for Emacs version. | 55 | ;; Check for Emacs version. |
| 56 | (let ((x (if (>= emacs-major-version 24) | 56 | (let ((x (if (>= emacs-major-version 24) |
| 57 | "ok" | 57 | "ok" |
| 58 | (format "Tramp 2.3.2-pre is not fit for %s" | 58 | (format "Tramp 2.3.2 is not fit for %s" |
| 59 | (when (string-match "^.*$" (emacs-version)) | 59 | (when (string-match "^.*$" (emacs-version)) |
| 60 | (match-string 0 (emacs-version))))))) | 60 | (match-string 0 (emacs-version))))))) |
| 61 | (unless (string-match "\\`ok\\'" x) (error "%s" x))) | 61 | (unless (string-match "\\`ok\\'" x) (error "%s" x))) |
diff --git a/lisp/net/html2text.el b/lisp/obsolete/html2text.el index 87c71dc504a..27560a70c63 100644 --- a/lisp/net/html2text.el +++ b/lisp/obsolete/html2text.el | |||
| @@ -3,6 +3,7 @@ | |||
| 3 | ;; Copyright (C) 2002-2017 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 2002-2017 Free Software Foundation, Inc. |
| 4 | 4 | ||
| 5 | ;; Author: Joakim Hove <hove@phys.ntnu.no> | 5 | ;; Author: Joakim Hove <hove@phys.ntnu.no> |
| 6 | ;; Obsolete-since: 26.1 | ||
| 6 | 7 | ||
| 7 | ;; This file is part of GNU Emacs. | 8 | ;; This file is part of GNU Emacs. |
| 8 | 9 | ||
| @@ -29,6 +30,8 @@ | |||
| 29 | ;; | 30 | ;; |
| 30 | ;; The main function is `html2text'. | 31 | ;; The main function is `html2text'. |
| 31 | 32 | ||
| 33 | ;; This package was obsoleted by shr.el. | ||
| 34 | |||
| 32 | ;;; Code: | 35 | ;;; Code: |
| 33 | 36 | ||
| 34 | ;; | 37 | ;; |
diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index c05200b3898..de2543951b9 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el | |||
| @@ -1915,7 +1915,7 @@ with a brace block." | |||
| 1915 | (save-restriction | 1915 | (save-restriction |
| 1916 | (let ((start (point)) | 1916 | (let ((start (point)) |
| 1917 | (paren-state (c-parse-state)) | 1917 | (paren-state (c-parse-state)) |
| 1918 | lim pos end-pos encl-decl-block where) | 1918 | lim pos end-pos where) |
| 1919 | ;; Narrow enclosing brace blocks out, as required by the values of | 1919 | ;; Narrow enclosing brace blocks out, as required by the values of |
| 1920 | ;; `c-defun-tactic', `near', and the position of point. | 1920 | ;; `c-defun-tactic', `near', and the position of point. |
| 1921 | (when (eq c-defun-tactic 'go-outward) | 1921 | (when (eq c-defun-tactic 'go-outward) |
diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index dd8f8afc6a3..85a4085e490 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el | |||
| @@ -44,19 +44,12 @@ | |||
| 44 | (load "cc-bytecomp" nil t))) | 44 | (load "cc-bytecomp" nil t))) |
| 45 | 45 | ||
| 46 | (eval-and-compile | 46 | (eval-and-compile |
| 47 | (defvar c--mapcan-status | 47 | (defvar c--cl-library |
| 48 | (cond ((and (fboundp 'mapcan) | 48 | (if (locate-library "cl-lib") |
| 49 | (subrp (symbol-function 'mapcan))) | 49 | 'cl-lib |
| 50 | ;; XEmacs | 50 | 'cl))) |
| 51 | 'mapcan) | 51 | |
| 52 | ((locate-file "cl-lib.elc" load-path) | 52 | (cc-external-require c--cl-library) |
| 53 | ;; Emacs >= 24.3 | ||
| 54 | 'cl-mapcan) | ||
| 55 | (t | ||
| 56 | ;; Emacs <= 24.2 | ||
| 57 | nil)))) | ||
| 58 | |||
| 59 | (cc-external-require (if (eq c--mapcan-status 'cl-mapcan) 'cl-lib 'cl)) | ||
| 60 | ; was (cc-external-require 'cl). ACM 2005/11/29. | 53 | ; was (cc-external-require 'cl). ACM 2005/11/29. |
| 61 | ; Changed from (eval-when-compile (require 'cl)) back to | 54 | ; Changed from (eval-when-compile (require 'cl)) back to |
| 62 | ; cc-external-require, 2015-08-12. | 55 | ; cc-external-require, 2015-08-12. |
| @@ -182,9 +175,12 @@ This variant works around bugs in `eval-when-compile' in various | |||
| 182 | ;; The motivation for this macro is to avoid the irritating message | 175 | ;; The motivation for this macro is to avoid the irritating message |
| 183 | ;; "function `mapcan' from cl package called at runtime" produced by Emacs. | 176 | ;; "function `mapcan' from cl package called at runtime" produced by Emacs. |
| 184 | (cond | 177 | (cond |
| 185 | ((eq c--mapcan-status 'mapcan) | 178 | ((and (fboundp 'mapcan) |
| 179 | (subrp (symbol-function 'mapcan))) | ||
| 180 | ;; XEmacs and Emacs >= 26. | ||
| 186 | `(mapcan ,fun ,liszt)) | 181 | `(mapcan ,fun ,liszt)) |
| 187 | ((eq c--mapcan-status 'cl-mapcan) | 182 | ((eq c--cl-library 'cl-lib) |
| 183 | ;; Emacs >= 24.3, < 26. | ||
| 188 | `(cl-mapcan ,fun ,liszt)) | 184 | `(cl-mapcan ,fun ,liszt)) |
| 189 | (t | 185 | (t |
| 190 | ;; Emacs <= 24.2. It would be nice to be able to distinguish between | 186 | ;; Emacs <= 24.2. It would be nice to be able to distinguish between |
| @@ -193,13 +189,13 @@ This variant works around bugs in `eval-when-compile' in various | |||
| 193 | 189 | ||
| 194 | (defmacro c--set-difference (liszt1 liszt2 &rest other-args) | 190 | (defmacro c--set-difference (liszt1 liszt2 &rest other-args) |
| 195 | ;; Macro to smooth out the renaming of `set-difference' in Emacs 24.3. | 191 | ;; Macro to smooth out the renaming of `set-difference' in Emacs 24.3. |
| 196 | (if (eq c--mapcan-status 'cl-mapcan) | 192 | (if (eq c--cl-library 'cl-lib) |
| 197 | `(cl-set-difference ,liszt1 ,liszt2 ,@other-args) | 193 | `(cl-set-difference ,liszt1 ,liszt2 ,@other-args) |
| 198 | `(set-difference ,liszt1 ,liszt2 ,@other-args))) | 194 | `(set-difference ,liszt1 ,liszt2 ,@other-args))) |
| 199 | 195 | ||
| 200 | (defmacro c--intersection (liszt1 liszt2 &rest other-args) | 196 | (defmacro c--intersection (liszt1 liszt2 &rest other-args) |
| 201 | ;; Macro to smooth out the renaming of `intersection' in Emacs 24.3. | 197 | ;; Macro to smooth out the renaming of `intersection' in Emacs 24.3. |
| 202 | (if (eq c--mapcan-status 'cl-mapcan) | 198 | (if (eq c--cl-library 'cl-lib) |
| 203 | `(cl-intersection ,liszt1 ,liszt2 ,@other-args) | 199 | `(cl-intersection ,liszt1 ,liszt2 ,@other-args) |
| 204 | `(intersection ,liszt1 ,liszt2 ,@other-args))) | 200 | `(intersection ,liszt1 ,liszt2 ,@other-args))) |
| 205 | 201 | ||
| @@ -212,7 +208,7 @@ This variant works around bugs in `eval-when-compile' in various | |||
| 212 | 208 | ||
| 213 | (defmacro c--delete-duplicates (cl-seq &rest cl-keys) | 209 | (defmacro c--delete-duplicates (cl-seq &rest cl-keys) |
| 214 | ;; Macro to smooth out the renaming of `delete-duplicates' in Emacs 24.3. | 210 | ;; Macro to smooth out the renaming of `delete-duplicates' in Emacs 24.3. |
| 215 | (if (eq c--mapcan-status 'cl-mapcan) | 211 | (if (eq c--cl-library 'cl-lib) |
| 216 | `(cl-delete-duplicates ,cl-seq ,@cl-keys) | 212 | `(cl-delete-duplicates ,cl-seq ,@cl-keys) |
| 217 | `(delete-duplicates ,cl-seq ,@cl-keys)))) | 213 | `(delete-duplicates ,cl-seq ,@cl-keys)))) |
| 218 | 214 | ||
| @@ -1175,6 +1171,63 @@ been put there by c-put-char-property. POINT remains unchanged." | |||
| 1175 | nil ,from ,to ,value nil -property-)) | 1171 | nil ,from ,to ,value nil -property-)) |
| 1176 | ;; GNU Emacs | 1172 | ;; GNU Emacs |
| 1177 | `(c-clear-char-property-with-value-function ,from ,to ,property ,value))) | 1173 | `(c-clear-char-property-with-value-function ,from ,to ,property ,value))) |
| 1174 | |||
| 1175 | (defun c-clear-char-property-with-value-on-char-function (from to property | ||
| 1176 | value char) | ||
| 1177 | "Remove all text-properties PROPERTY with value VALUE on | ||
| 1178 | characters with value CHAR from the region [FROM, TO), as tested | ||
| 1179 | by `equal'. These properties are assumed to be over individual | ||
| 1180 | characters, having been put there by c-put-char-property. POINT | ||
| 1181 | remains unchanged." | ||
| 1182 | (let ((place from) | ||
| 1183 | ) | ||
| 1184 | (while ; loop round occurrences of (PROPERTY VALUE) | ||
| 1185 | (progn | ||
| 1186 | (while ; loop round changes in PROPERTY till we find VALUE | ||
| 1187 | (and | ||
| 1188 | (< place to) | ||
| 1189 | (not (equal (get-text-property place property) value))) | ||
| 1190 | (setq place (c-next-single-property-change place property nil to))) | ||
| 1191 | (< place to)) | ||
| 1192 | (if (eq (char-after place) char) | ||
| 1193 | (remove-text-properties place (1+ place) (cons property nil))) | ||
| 1194 | ;; Do we have to do anything with stickiness here? | ||
| 1195 | (setq place (1+ place))))) | ||
| 1196 | |||
| 1197 | (defmacro c-clear-char-property-with-value-on-char (from to property value char) | ||
| 1198 | "Remove all text-properties PROPERTY with value VALUE on | ||
| 1199 | characters with value CHAR from the region [FROM, TO), as tested | ||
| 1200 | by `equal'. These properties are assumed to be over individual | ||
| 1201 | characters, having been put there by c-put-char-property. POINT | ||
| 1202 | remains unchanged." | ||
| 1203 | (if c-use-extents | ||
| 1204 | ;; XEmacs | ||
| 1205 | `(let ((-property- ,property) | ||
| 1206 | (-char- ,char)) | ||
| 1207 | (map-extents (lambda (ext val) | ||
| 1208 | (if (and (equal (extent-property ext -property-) val) | ||
| 1209 | (eq (char-after | ||
| 1210 | (extent-start-position ext)) | ||
| 1211 | -char-)) | ||
| 1212 | (delete-extent ext))) | ||
| 1213 | nil ,from ,to ,value nil -property-)) | ||
| 1214 | ;; Gnu Emacs | ||
| 1215 | `(c-clear-char-property-with-value-on-char-function ,from ,to ,property | ||
| 1216 | ,value ,char))) | ||
| 1217 | |||
| 1218 | (defmacro c-put-char-properties-on-char (from to property value char) | ||
| 1219 | ;; This needs to be a macro because `property' passed to | ||
| 1220 | ;; `c-put-char-property' must be a constant. | ||
| 1221 | "Put the text property PROPERTY with value VALUE on characters | ||
| 1222 | with value CHAR in the region [FROM to)." | ||
| 1223 | `(let ((skip-string (concat "^" (list ,char))) | ||
| 1224 | (-to- ,to)) | ||
| 1225 | (save-excursion | ||
| 1226 | (goto-char ,from) | ||
| 1227 | (while (progn (skip-chars-forward skip-string -to-) | ||
| 1228 | (< (point) -to-)) | ||
| 1229 | (c-put-char-property (point) ,property ,value) | ||
| 1230 | (forward-char))))) | ||
| 1178 | 1231 | ||
| 1179 | ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. | 1232 | ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. |
| 1180 | ;; For our purposes, these are characterized by being possible to | 1233 | ;; For our purposes, these are characterized by being possible to |
| @@ -1232,6 +1285,8 @@ been put there by c-put-char-property. POINT remains unchanged." | |||
| 1232 | (def-edebug-spec c-put-char-property t) | 1285 | (def-edebug-spec c-put-char-property t) |
| 1233 | (def-edebug-spec c-get-char-property t) | 1286 | (def-edebug-spec c-get-char-property t) |
| 1234 | (def-edebug-spec c-clear-char-property t) | 1287 | (def-edebug-spec c-clear-char-property t) |
| 1288 | (def-edebug-spec c-clear-char-property-with-value-on-char t) | ||
| 1289 | (def-edebug-spec c-put-char-properties-on-char t) | ||
| 1235 | (def-edebug-spec c-clear-char-properties t) | 1290 | (def-edebug-spec c-clear-char-properties t) |
| 1236 | (def-edebug-spec c-put-overlay t) | 1291 | (def-edebug-spec c-put-overlay t) |
| 1237 | (def-edebug-spec c-delete-overlay t) | 1292 | (def-edebug-spec c-delete-overlay t) |
diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index aa84ade083c..955e1ebb08d 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el | |||
| @@ -4809,7 +4809,6 @@ comment at the start of cc-engine.el for more info." | |||
| 4809 | 4809 | ||
| 4810 | (c-self-bind-state-cache | 4810 | (c-self-bind-state-cache |
| 4811 | (let ((start (point)) | 4811 | (let ((start (point)) |
| 4812 | state-2 | ||
| 4813 | ;; A list of syntactically relevant positions in descending | 4812 | ;; A list of syntactically relevant positions in descending |
| 4814 | ;; order. It's used to avoid scanning repeatedly over | 4813 | ;; order. It's used to avoid scanning repeatedly over |
| 4815 | ;; potentially large regions with `parse-partial-sexp' to verify | 4814 | ;; potentially large regions with `parse-partial-sexp' to verify |
| @@ -7809,8 +7808,7 @@ comment at the start of cc-engine.el for more info." | |||
| 7809 | ;; looking (in C++) like this "FQN::of::base::Class". Move to the start of | 7808 | ;; looking (in C++) like this "FQN::of::base::Class". Move to the start of |
| 7810 | ;; this construct and return t. If the parsing fails, return nil, leaving | 7809 | ;; this construct and return t. If the parsing fails, return nil, leaving |
| 7811 | ;; point unchanged. | 7810 | ;; point unchanged. |
| 7812 | (let ((here (point)) | 7811 | (let (end) |
| 7813 | end) | ||
| 7814 | (if (not (c-on-identifier)) | 7812 | (if (not (c-on-identifier)) |
| 7815 | nil | 7813 | nil |
| 7816 | (c-simple-skip-symbol-backward) | 7814 | (c-simple-skip-symbol-backward) |
diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 9bae7d9aa2f..66f2575f49f 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el | |||
| @@ -702,6 +702,36 @@ stuff. Used on level 1 and higher." | |||
| 702 | t) | 702 | t) |
| 703 | (c-put-font-lock-face start (1+ start) 'font-lock-warning-face))))) | 703 | (c-put-font-lock-face start (1+ start) 'font-lock-warning-face))))) |
| 704 | 704 | ||
| 705 | (defun c-font-lock-invalid-single-quotes (limit) | ||
| 706 | ;; This function will be called from font-lock for a region bounded by POINT | ||
| 707 | ;; and LIMIT, as though it were to identify a keyword for | ||
| 708 | ;; font-lock-keyword-face. It always returns NIL to inhibit this and | ||
| 709 | ;; prevent a repeat invocation. See elisp/lispref page "Search-based | ||
| 710 | ;; Fontification". | ||
| 711 | ;; | ||
| 712 | ;; This function fontifies invalid single quotes with | ||
| 713 | ;; `font-lock-warning-face'. These are the single quotes which | ||
| 714 | ;; o - aren't inside a literal; | ||
| 715 | ;; o - are marked with a syntax-table text property value '(1); and | ||
| 716 | ;; o - are NOT marked with a non-null c-digit-separator property. | ||
| 717 | (let ((limits (c-literal-limits)) | ||
| 718 | state beg end) | ||
| 719 | (if limits | ||
| 720 | (goto-char (cdr limits))) ; Even for being in a ' ' | ||
| 721 | (while (< (point) limit) | ||
| 722 | (setq beg (point)) | ||
| 723 | (setq state (parse-partial-sexp (point) limit nil nil nil 'syntax-table)) | ||
| 724 | (setq end (point)) | ||
| 725 | (goto-char beg) | ||
| 726 | (while (progn (skip-chars-forward "^'" end) | ||
| 727 | (< (point) end)) | ||
| 728 | (if (and (equal (c-get-char-property (point) 'syntax-table) '(1)) | ||
| 729 | (not (c-get-char-property (point) 'c-digit-separator))) | ||
| 730 | (c-put-font-lock-face (point) (1+ (point)) font-lock-warning-face)) | ||
| 731 | (forward-char)) | ||
| 732 | (parse-partial-sexp end limit nil nil state 'syntax-table))) | ||
| 733 | nil) | ||
| 734 | |||
| 705 | (c-lang-defconst c-basic-matchers-before | 735 | (c-lang-defconst c-basic-matchers-before |
| 706 | "Font lock matchers for basic keywords, labels, references and various | 736 | "Font lock matchers for basic keywords, labels, references and various |
| 707 | other easily recognizable things that should be fontified before generic | 737 | other easily recognizable things that should be fontified before generic |
| @@ -723,6 +753,9 @@ casts and declarations are fontified. Used on level 2 and higher." | |||
| 723 | (concat ".\\(" c-string-limit-regexp "\\)") | 753 | (concat ".\\(" c-string-limit-regexp "\\)") |
| 724 | '((c-font-lock-invalid-string))) | 754 | '((c-font-lock-invalid-string))) |
| 725 | 755 | ||
| 756 | ;; Invalid single quotes. | ||
| 757 | c-font-lock-invalid-single-quotes | ||
| 758 | |||
| 726 | ;; Fontify C++ raw strings. | 759 | ;; Fontify C++ raw strings. |
| 727 | ,@(when (c-major-mode-is 'c++-mode) | 760 | ,@(when (c-major-mode-is 'c++-mode) |
| 728 | '(c-font-lock-raw-strings)) | 761 | '(c-font-lock-raw-strings)) |
| @@ -777,7 +810,8 @@ casts and declarations are fontified. Used on level 2 and higher." | |||
| 777 | (c-backward-syntactic-ws) | 810 | (c-backward-syntactic-ws) |
| 778 | (setq id-end (point)) | 811 | (setq id-end (point)) |
| 779 | (< (skip-chars-backward | 812 | (< (skip-chars-backward |
| 780 | ,(c-lang-const c-symbol-chars)) 0)) | 813 | ,(c-lang-const c-symbol-chars)) |
| 814 | 0)) | ||
| 781 | (not (get-text-property (point) 'face))) | 815 | (not (get-text-property (point) 'face))) |
| 782 | (c-put-font-lock-face (point) id-end | 816 | (c-put-font-lock-face (point) id-end |
| 783 | c-reference-face-name) | 817 | c-reference-face-name) |
| @@ -1013,13 +1047,11 @@ casts and declarations are fontified. Used on level 2 and higher." | |||
| 1013 | 1047 | ||
| 1014 | ;;(message "c-font-lock-declarators from %s to %s" (point) limit) | 1048 | ;;(message "c-font-lock-declarators from %s to %s" (point) limit) |
| 1015 | (c-fontify-types-and-refs | 1049 | (c-fontify-types-and-refs |
| 1016 | ((pos (point)) next-pos id-start id-end | 1050 | ((pos (point)) next-pos id-start |
| 1017 | decl-res | 1051 | decl-res |
| 1018 | paren-depth | ||
| 1019 | id-face got-type got-init | 1052 | id-face got-type got-init |
| 1020 | c-last-identifier-range | 1053 | c-last-identifier-range |
| 1021 | (separator-prop (if types 'c-decl-type-start 'c-decl-id-start)) | 1054 | (separator-prop (if types 'c-decl-type-start 'c-decl-id-start))) |
| 1022 | brackets-after-id) | ||
| 1023 | 1055 | ||
| 1024 | ;; The following `while' fontifies a single declarator id each time round. | 1056 | ;; The following `while' fontifies a single declarator id each time round. |
| 1025 | ;; It loops only when LIST is non-nil. | 1057 | ;; It loops only when LIST is non-nil. |
| @@ -1036,7 +1068,7 @@ casts and declarations are fontified. Used on level 2 and higher." | |||
| 1036 | (forward-char) | 1068 | (forward-char) |
| 1037 | (c-forward-syntactic-ws) | 1069 | (c-forward-syntactic-ws) |
| 1038 | (looking-at "[*&]"))) | 1070 | (looking-at "[*&]"))) |
| 1039 | (not (car (cddr decl-res))) ; brackets-after-id | 1071 | (not (car (cddr decl-res))) |
| 1040 | (or (not (c-major-mode-is 'c++-mode)) | 1072 | (or (not (c-major-mode-is 'c++-mode)) |
| 1041 | (save-excursion | 1073 | (save-excursion |
| 1042 | (let (c-last-identifier-range) | 1074 | (let (c-last-identifier-range) |
| @@ -1375,7 +1407,6 @@ casts and declarations are fontified. Used on level 2 and higher." | |||
| 1375 | ;; it finds any. That's necessary so that we later will | 1407 | ;; it finds any. That's necessary so that we later will |
| 1376 | ;; stop inside them to fontify types there. | 1408 | ;; stop inside them to fontify types there. |
| 1377 | (c-parse-and-markup-<>-arglists t) | 1409 | (c-parse-and-markup-<>-arglists t) |
| 1378 | lbrace ; position of some {. | ||
| 1379 | ;; The font-lock package in Emacs is known to clobber | 1410 | ;; The font-lock package in Emacs is known to clobber |
| 1380 | ;; `parse-sexp-lookup-properties' (when it exists). | 1411 | ;; `parse-sexp-lookup-properties' (when it exists). |
| 1381 | (parse-sexp-lookup-properties | 1412 | (parse-sexp-lookup-properties |
| @@ -2503,7 +2534,7 @@ need for `c++-font-lock-extra-types'.") | |||
| 2503 | limit | 2534 | limit |
| 2504 | "[-+]" | 2535 | "[-+]" |
| 2505 | nil | 2536 | nil |
| 2506 | (lambda (match-pos inside-macro &optional top-level) | 2537 | (lambda (_match-pos _inside-macro &optional _top-level) |
| 2507 | (forward-char) | 2538 | (forward-char) |
| 2508 | (c-font-lock-objc-method)))) | 2539 | (c-font-lock-objc-method)))) |
| 2509 | nil) | 2540 | nil) |
diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index a9d5ac34ad4..8be806094cd 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el | |||
| @@ -130,7 +130,7 @@ | |||
| 130 | 130 | ||
| 131 | 131 | ||
| 132 | ;; This file is not always loaded. See note above. | 132 | ;; This file is not always loaded. See note above. |
| 133 | (cc-external-require (if (eq c--mapcan-status 'cl-mapcan) 'cl-lib 'cl)) | 133 | (cc-external-require (if (eq c--cl-library 'cl-lib) 'cl-lib 'cl)) |
| 134 | 134 | ||
| 135 | 135 | ||
| 136 | ;;; Setup for the `c-lang-defvar' system. | 136 | ;;; Setup for the `c-lang-defvar' system. |
| @@ -474,18 +474,19 @@ so that all identifiers are recognized as words.") | |||
| 474 | ;; The value here may be a list of functions or a single function. | 474 | ;; The value here may be a list of functions or a single function. |
| 475 | t nil | 475 | t nil |
| 476 | c++ '(c-extend-region-for-CPP | 476 | c++ '(c-extend-region-for-CPP |
| 477 | ; c-before-after-change-extend-region-for-lambda-capture ; doesn't seem needed. | ||
| 478 | c-before-change-check-raw-strings | 477 | c-before-change-check-raw-strings |
| 479 | c-before-change-check-<>-operators | 478 | c-before-change-check-<>-operators |
| 480 | c-depropertize-CPP | 479 | c-depropertize-CPP |
| 481 | c-before-after-change-digit-quote | ||
| 482 | c-invalidate-macro-cache | 480 | c-invalidate-macro-cache |
| 483 | c-truncate-bs-cache) | 481 | c-truncate-bs-cache |
| 482 | c-parse-quotes-before-change) | ||
| 484 | (c objc) '(c-extend-region-for-CPP | 483 | (c objc) '(c-extend-region-for-CPP |
| 485 | c-depropertize-CPP | 484 | c-depropertize-CPP |
| 486 | c-invalidate-macro-cache | 485 | c-invalidate-macro-cache |
| 487 | c-truncate-bs-cache) | 486 | c-truncate-bs-cache |
| 488 | ;; java 'c-before-change-check-<>-operators | 487 | c-parse-quotes-before-change) |
| 488 | java 'c-parse-quotes-before-change | ||
| 489 | ;; 'c-before-change-check-<>-operators | ||
| 489 | awk 'c-awk-record-region-clear-NL) | 490 | awk 'c-awk-record-region-clear-NL) |
| 490 | (c-lang-defvar c-get-state-before-change-functions | 491 | (c-lang-defvar c-get-state-before-change-functions |
| 491 | (let ((fs (c-lang-const c-get-state-before-change-functions))) | 492 | (let ((fs (c-lang-const c-get-state-before-change-functions))) |
| @@ -515,18 +516,19 @@ parameters \(point-min) and \(point-max).") | |||
| 515 | t '(c-depropertize-new-text | 516 | t '(c-depropertize-new-text |
| 516 | c-change-expand-fl-region) | 517 | c-change-expand-fl-region) |
| 517 | (c objc) '(c-depropertize-new-text | 518 | (c objc) '(c-depropertize-new-text |
| 519 | c-parse-quotes-after-change | ||
| 518 | c-extend-font-lock-region-for-macros | 520 | c-extend-font-lock-region-for-macros |
| 519 | c-neutralize-syntax-in-and-mark-CPP | 521 | c-neutralize-syntax-in-and-mark-CPP |
| 520 | c-change-expand-fl-region) | 522 | c-change-expand-fl-region) |
| 521 | c++ '(c-depropertize-new-text | 523 | c++ '(c-depropertize-new-text |
| 524 | c-parse-quotes-after-change | ||
| 522 | c-extend-font-lock-region-for-macros | 525 | c-extend-font-lock-region-for-macros |
| 523 | ; c-before-after-change-extend-region-for-lambda-capture ; doesn't seem needed. | ||
| 524 | c-before-after-change-digit-quote | ||
| 525 | c-after-change-re-mark-raw-strings | 526 | c-after-change-re-mark-raw-strings |
| 526 | c-neutralize-syntax-in-and-mark-CPP | 527 | c-neutralize-syntax-in-and-mark-CPP |
| 527 | c-restore-<>-properties | 528 | c-restore-<>-properties |
| 528 | c-change-expand-fl-region) | 529 | c-change-expand-fl-region) |
| 529 | java '(c-depropertize-new-text | 530 | java '(c-depropertize-new-text |
| 531 | c-parse-quotes-after-change | ||
| 530 | c-restore-<>-properties | 532 | c-restore-<>-properties |
| 531 | c-change-expand-fl-region) | 533 | c-change-expand-fl-region) |
| 532 | awk '(c-depropertize-new-text | 534 | awk '(c-depropertize-new-text |
| @@ -609,6 +611,12 @@ EOL terminated statements." | |||
| 609 | (c c++ objc) t) | 611 | (c c++ objc) t) |
| 610 | (c-lang-defvar c-has-bitfields (c-lang-const c-has-bitfields)) | 612 | (c-lang-defvar c-has-bitfields (c-lang-const c-has-bitfields)) |
| 611 | 613 | ||
| 614 | (c-lang-defconst c-has-quoted-numbers | ||
| 615 | "Whether the language has numbers quoted like 4'294'967'295." | ||
| 616 | t nil | ||
| 617 | c++ t) | ||
| 618 | (c-lang-defvar c-has-quoted-numbers (c-lang-const c-has-quoted-numbers)) | ||
| 619 | |||
| 612 | (c-lang-defconst c-modified-constant | 620 | (c-lang-defconst c-modified-constant |
| 613 | "Regexp that matches a “modified” constant literal such as \"L\\='a\\='\", | 621 | "Regexp that matches a “modified” constant literal such as \"L\\='a\\='\", |
| 614 | a “long character”. In particular, this recognizes forms of constant | 622 | a “long character”. In particular, this recognizes forms of constant |
diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index a501ebba256..ef93f75c5f3 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el | |||
| @@ -1083,101 +1083,219 @@ Note that the style variables are always made local to the buffer." | |||
| 1083 | (forward-line)) ; no infinite loop with, e.g., "#//" | 1083 | (forward-line)) ; no infinite loop with, e.g., "#//" |
| 1084 | ))))) | 1084 | ))))) |
| 1085 | 1085 | ||
| 1086 | (defun c-before-after-change-digit-quote (beg end &optional old-len) | 1086 | ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; |
| 1087 | ;; This function either removes or applies the punctuation value ('(1)) of | 1087 | ;; Parsing of quotes. |
| 1088 | ;; the `syntax-table' text property on single quote marks which are | 1088 | ;; |
| 1089 | ;; separator characters in long integer literals, e.g. "4'294'967'295". It | 1089 | ;; Valid digit separators in numbers will get the syntax-table "punctuation" |
| 1090 | ;; applies to both decimal/octal and hex literals. (FIXME (2016-06-10): it | 1090 | ;; property, '(1), and also the text property `c-digit-separator' value t. |
| 1091 | ;; should also apply to binary literals.) | 1091 | ;; |
| 1092 | ;; Invalid other quotes (i.e. those not validly bounding a single character, | ||
| 1093 | ;; or escaped character) will get the syntax-table "punctuation" property, | ||
| 1094 | ;; '(1), too. | ||
| 1095 | ;; | ||
| 1096 | ;; Note that, for convenience, these properties are applied even inside | ||
| 1097 | ;; comments and strings. | ||
| 1098 | |||
| 1099 | (defconst c-maybe-quoted-number-head | ||
| 1100 | (concat | ||
| 1101 | "\\(0\\(" | ||
| 1102 | "\\([Xx]\\([0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*'?\\)?\\)" | ||
| 1103 | "\\|" | ||
| 1104 | "\\([Bb]\\([01]\\('[01]\\|[01]\\)*'?\\)?\\)" | ||
| 1105 | "\\|" | ||
| 1106 | "\\('[0-7]\\|[0-7]\\)*'?" | ||
| 1107 | "\\)" | ||
| 1108 | "\\|" | ||
| 1109 | "[1-9]\\('[0-9]\\|[0-9]\\)*'?" | ||
| 1110 | "\\)") | ||
| 1111 | "Regexp matching the head of a numeric literal, including with digit separators.") | ||
| 1112 | |||
| 1113 | (defun c-quoted-number-head-before-point () | ||
| 1114 | ;; Return non-nil when the head of a possibly quoted number is found | ||
| 1115 | ;; immediately before point. The value returned in this case is the buffer | ||
| 1116 | ;; position of the start of the head. That position is also in | ||
| 1117 | ;; (match-beginning 0). | ||
| 1118 | (when c-has-quoted-numbers | ||
| 1119 | (save-excursion | ||
| 1120 | (let ((here (point)) | ||
| 1121 | found) | ||
| 1122 | (skip-chars-backward "0-9a-fA-F'") | ||
| 1123 | (if (and (memq (char-before) '(?x ?X)) | ||
| 1124 | (eq (char-before (1- (point))) ?0)) | ||
| 1125 | (backward-char 2)) | ||
| 1126 | (while | ||
| 1127 | (and | ||
| 1128 | (setq found | ||
| 1129 | (search-forward-regexp c-maybe-quoted-number-head here t)) | ||
| 1130 | (< found here))) | ||
| 1131 | (and (eq found here) (match-beginning 0)))))) | ||
| 1132 | |||
| 1133 | (defconst c-maybe-quoted-number-tail | ||
| 1134 | (concat | ||
| 1135 | "\\(" | ||
| 1136 | "\\([xX']?[0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*\\)" | ||
| 1137 | "\\|" | ||
| 1138 | "\\([bB']?[01]\\('[01]\\|[01]\\)*\\)" | ||
| 1139 | "\\|" | ||
| 1140 | "\\('?[0-9]\\('[0-9]\\|[0-9]\\)*\\)" | ||
| 1141 | "\\)") | ||
| 1142 | "Regexp matching the tail of a numeric literal, including with digit separators. | ||
| 1143 | Note that this is a strict tail, so won't match, e.g. \"0x....\".") | ||
| 1144 | |||
| 1145 | (defun c-quoted-number-tail-after-point () | ||
| 1146 | ;; Return non-nil when a proper tail of a possibly quoted number is found | ||
| 1147 | ;; immediately after point. The value returned in this case is the buffer | ||
| 1148 | ;; position of the end of the tail. That position is also in (match-end 0). | ||
| 1149 | (when c-has-quoted-numbers | ||
| 1150 | (and (looking-at c-maybe-quoted-number-tail) | ||
| 1151 | (match-end 0)))) | ||
| 1152 | |||
| 1153 | (defconst c-maybe-quoted-number | ||
| 1154 | (concat | ||
| 1155 | "\\(0\\(" | ||
| 1156 | "\\([Xx][0-9a-fA-F]\\('[0-9a-fA-F]\\|[0-9a-fA-F]\\)*\\)" | ||
| 1157 | "\\|" | ||
| 1158 | "\\([Bb][01]\\('[01]\\|[01]\\)*\\)" | ||
| 1159 | "\\|" | ||
| 1160 | "\\('[0-7]\\|[0-7]\\)*" | ||
| 1161 | "\\)" | ||
| 1162 | "\\|" | ||
| 1163 | "[1-9]\\('[0-9]\\|[0-9]\\)*" | ||
| 1164 | "\\)") | ||
| 1165 | "Regexp matching a numeric literal, including with digit separators.") | ||
| 1166 | |||
| 1167 | (defun c-quoted-number-straddling-point () | ||
| 1168 | ;; Return non-nil if a definitely quoted number starts before point and ends | ||
| 1169 | ;; after point. In this case the number is bounded by (match-beginning 0) | ||
| 1170 | ;; and (match-end 0). | ||
| 1171 | (when c-has-quoted-numbers | ||
| 1172 | (save-excursion | ||
| 1173 | (let ((here (point)) | ||
| 1174 | (bound (progn (skip-chars-forward "0-9a-fA-F'") (point)))) | ||
| 1175 | (goto-char here) | ||
| 1176 | (when (< (skip-chars-backward "0-9a-fA-F'") 0) | ||
| 1177 | (if (and (memq (char-before) '(?x ?X)) | ||
| 1178 | (eq (char-before (1- (point))) ?0)) | ||
| 1179 | (backward-char 2)) | ||
| 1180 | (while (and (search-forward-regexp c-maybe-quoted-number bound t) | ||
| 1181 | (<= (match-end 0) here))) | ||
| 1182 | (and (< (match-beginning 0) here) | ||
| 1183 | (> (match-end 0) here) | ||
| 1184 | (save-match-data | ||
| 1185 | (goto-char (match-beginning 0)) | ||
| 1186 | (save-excursion (search-forward "'" (match-end 0) t))))))))) | ||
| 1187 | |||
| 1188 | (defun c-parse-quotes-before-change (beg end) | ||
| 1189 | ;; This function analyzes 's near the region (c-new-BEG c-new-END), amending | ||
| 1190 | ;; those two variables as needed to include 's into that region when they | ||
| 1191 | ;; might be syntactically relevant to the change in progress. | ||
| 1092 | ;; | 1192 | ;; |
| 1093 | ;; In both uses of the function, the `syntax-table' properties are | 1193 | ;; Having amended that region, the function removes pertinent text |
| 1094 | ;; removed/applied only on quote marks which appear to be digit separators. | 1194 | ;; properties (syntax-table properties with value '(1) and c-digit-separator |
| 1195 | ;; props with value t) from 's in it. This operation is performed even | ||
| 1196 | ;; within strings and comments. | ||
| 1095 | ;; | 1197 | ;; |
| 1096 | ;; Point is undefined on both entry and exit to this function, and the | 1198 | ;; This function is called exclusively as a before-change function via the |
| 1097 | ;; return value has no significance. The function is called solely as a | 1199 | ;; variable `c-get-state-before-change-functions'. |
| 1098 | ;; before-change function (see `c-get-state-before-change-functions') and as | 1200 | (c-save-buffer-state (p-limit limits found) |
| 1099 | ;; an after change function (see `c-before-font-lock-functions', with the | 1201 | ;; Special consideraton for deleting \ from '\''. |
| 1100 | ;; parameters BEG, END, and (optionally) OLD-LEN being given the standard | 1202 | (if (and (> end beg) |
| 1101 | ;; values for before/after-change functions. | 1203 | (eq (char-before end) ?\\) |
| 1102 | (c-save-buffer-state ((num-begin c-new-BEG) digit-re try-end) | 1204 | (<= c-new-END end)) |
| 1205 | (setq c-new-END (min (1+ end) (point-max)))) | ||
| 1206 | |||
| 1207 | ;; Do we have a ' (or something like ',',',',',') within range of | ||
| 1208 | ;; c-new-BEG? | ||
| 1209 | (goto-char c-new-BEG) | ||
| 1210 | (setq p-limit (max (- (point) 2) (point-min))) | ||
| 1211 | (while (and (skip-chars-backward "^\\\\'" p-limit) | ||
| 1212 | (> (point) p-limit)) | ||
| 1213 | (when (eq (char-before) ?\\) | ||
| 1214 | (setq p-limit (max (1- p-limit) (point-min)))) | ||
| 1215 | (backward-char) | ||
| 1216 | (setq c-new-BEG (point))) | ||
| 1217 | (beginning-of-line) | ||
| 1218 | (while (and | ||
| 1219 | (setq found (search-forward-regexp "\\('\\([^'\\]\\|\\\\.\\)\\)*'" | ||
| 1220 | c-new-BEG 'limit)) | ||
| 1221 | (< (point) (1- c-new-BEG)))) | ||
| 1222 | (if found | ||
| 1223 | (setq c-new-BEG | ||
| 1224 | (if (and (eq (point) (1- c-new-BEG)) | ||
| 1225 | (eq (char-after) ?')) ; "''" before c-new-BEG. | ||
| 1226 | (1- c-new-BEG) | ||
| 1227 | (match-beginning 0)))) | ||
| 1228 | |||
| 1229 | ;; Check for a number with quote separators straddling c-new-BEG | ||
| 1230 | (when c-has-quoted-numbers | ||
| 1231 | (goto-char c-new-BEG) | ||
| 1232 | (when ;; (c-quoted-number-straddling-point) | ||
| 1233 | (c-quoted-number-head-before-point) | ||
| 1234 | (setq c-new-BEG (match-beginning 0)))) | ||
| 1235 | |||
| 1236 | ;; Do we have a ' (or something like ',',',',...,',') within range of | ||
| 1237 | ;; c-new-END? | ||
| 1103 | (goto-char c-new-END) | 1238 | (goto-char c-new-END) |
| 1104 | (when (looking-at "\\(x\\)?[0-9a-fA-F']+") | 1239 | (setq p-limit (min (+ (point) 2) (point-max))) |
| 1105 | (setq c-new-END (match-end 0))) | 1240 | (while (and (skip-chars-forward "^\\\\'" p-limit) |
| 1241 | (< (point) p-limit)) | ||
| 1242 | (when (eq (char-after) ?\\) | ||
| 1243 | (setq p-limit (min (1+ p-limit) (point-max)))) | ||
| 1244 | (forward-char) | ||
| 1245 | (setq c-new-END (point))) | ||
| 1246 | (if (looking-at "[^']?\\('\\([^'\\]\\|\\\\.\\)\\)*'") | ||
| 1247 | (setq c-new-END (match-end 0))) | ||
| 1248 | |||
| 1249 | ;; Check for a number with quote separators straddling c-new-END. | ||
| 1250 | (when c-has-quoted-numbers | ||
| 1251 | (goto-char c-new-END) | ||
| 1252 | (when ;; (c-quoted-number-straddling-point) | ||
| 1253 | (c-quoted-number-tail-after-point) | ||
| 1254 | (setq c-new-END (match-end 0)))) | ||
| 1255 | |||
| 1256 | ;; Remove the '(1) syntax-table property from all "'"s within (c-new-BEG | ||
| 1257 | ;; c-new-END). | ||
| 1258 | (c-clear-char-property-with-value-on-char | ||
| 1259 | c-new-BEG c-new-END | ||
| 1260 | 'syntax-table '(1) | ||
| 1261 | ?') | ||
| 1262 | ;; Remove the c-digit-separator text property from the same "'"s. | ||
| 1263 | (when c-has-quoted-numbers | ||
| 1264 | (c-clear-char-property-with-value-on-char | ||
| 1265 | c-new-BEG c-new-END | ||
| 1266 | 'c-digit-separator t | ||
| 1267 | ?')))) | ||
| 1268 | |||
| 1269 | (defun c-parse-quotes-after-change (beg end old-len) | ||
| 1270 | ;; This function applies syntax-table properties (value '(1)) and | ||
| 1271 | ;; c-digit-separator properties as needed to 's within the range (c-new-BEG | ||
| 1272 | ;; c-new-END). This operation is performed even within strings and | ||
| 1273 | ;; comments. | ||
| 1274 | ;; | ||
| 1275 | ;; This function is called exclusively as an after-change function via the | ||
| 1276 | ;; variable `c-before-font-lock-functions'. | ||
| 1277 | (c-save-buffer-state (p-limit limits num-beg num-end clear-from-BEG-to) | ||
| 1278 | ;; Apply the needed syntax-table and c-digit-separator text properties to | ||
| 1279 | ;; quotes. | ||
| 1106 | (goto-char c-new-BEG) | 1280 | (goto-char c-new-BEG) |
| 1107 | (when (looking-at "\\(x?\\)[0-9a-fA-F']") | 1281 | (while (and (< (point) c-new-END) |
| 1108 | (if (re-search-backward "\\(0x\\)?[0-9a-fA-F]*\\=" nil t) | 1282 | (search-forward "'" c-new-END 'limit)) |
| 1109 | (setq c-new-BEG (point)))) | 1283 | (cond ((and (eq (char-before (1- (point))) ?\\) |
| 1110 | 1284 | ;; Check we've got an odd number of \s, here. | |
| 1111 | (while | ||
| 1112 | (re-search-forward "[0-9a-fA-F]'[0-9a-fA-F]" c-new-END t) | ||
| 1113 | (setq try-end (1- (point))) | ||
| 1114 | (re-search-backward "[^0-9a-fA-F']" num-begin t) | ||
| 1115 | (setq digit-re | ||
| 1116 | (cond | ||
| 1117 | ((and (not (bobp)) (eq (char-before) ?0) (memq (char-after) '(?x ?X))) | ||
| 1118 | "[0-9a-fA-F]") | ||
| 1119 | ((and (eq (char-after (1+ (point))) ?0) | ||
| 1120 | (memq (char-after (+ 2 (point))) '(?b ?B))) | ||
| 1121 | "[01]") | ||
| 1122 | ((memq (char-after (1+ (point))) '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) | ||
| 1123 | "[0-9]") | ||
| 1124 | (t nil))) | ||
| 1125 | (when digit-re | ||
| 1126 | (cond ((eq (char-after) ?x) (forward-char)) | ||
| 1127 | ((looking-at ".?0[Bb]") (goto-char (match-end 0))) | ||
| 1128 | ((looking-at digit-re)) | ||
| 1129 | (t (forward-char))) | ||
| 1130 | (when (not (c-in-literal)) | ||
| 1131 | (let ((num-end ; End of valid sequence of digits/quotes. | ||
| 1132 | (save-excursion | ||
| 1133 | (re-search-forward | ||
| 1134 | (concat "\\=\\(" digit-re "+'\\)*" digit-re "+") nil t) | ||
| 1135 | (point)))) | ||
| 1136 | (setq try-end ; End of sequence of digits/quotes | ||
| 1137 | (save-excursion | 1285 | (save-excursion |
| 1138 | (re-search-forward | 1286 | (backward-char) |
| 1139 | (concat "\\=\\(" digit-re "\\|'\\)+") nil t) | 1287 | (eq (logand (skip-chars-backward "\\\\") 1) 1)))) ; not a real '. |
| 1140 | (point))) | 1288 | ((c-quoted-number-straddling-point) |
| 1141 | (while (re-search-forward | 1289 | (setq num-beg (match-beginning 0) |
| 1142 | (concat digit-re "\\('\\)" digit-re) num-end t) | 1290 | num-end (match-end 0)) |
| 1143 | (if old-len ; i.e. are we in an after-change function? | 1291 | (c-put-char-properties-on-char num-beg num-end |
| 1144 | (c-put-char-property (match-beginning 1) 'syntax-table '(1)) | 1292 | 'syntax-table '(1) ?') |
| 1145 | (c-clear-char-property (match-beginning 1) 'syntax-table)) | 1293 | (c-put-char-properties-on-char num-beg num-end |
| 1146 | (backward-char))))) | 1294 | 'c-digit-separator t ?') |
| 1147 | (goto-char try-end) | 1295 | (goto-char num-end)) |
| 1148 | (setq num-begin (point))))) | 1296 | ((looking-at "\\([^\\']\\|\\\\.\\)'") ; balanced quoted expression. |
| 1149 | 1297 | (goto-char (match-end 0))) | |
| 1150 | ;; The following doesn't seem needed at the moment (2016-08-15). | 1298 | (t (c-put-char-property (1- (point)) 'syntax-table '(1))))))) |
| 1151 | ;; (defun c-before-after-change-extend-region-for-lambda-capture | ||
| 1152 | ;; (_beg _end &optional _old-len) | ||
| 1153 | ;; ;; In C++ Mode, extend the region (c-new-BEG c-new-END) to cover any lambda | ||
| 1154 | ;; ;; function capture lists we happen to be inside. This function is expected | ||
| 1155 | ;; ;; to be called both as a before-change and after change function. | ||
| 1156 | ;; ;; | ||
| 1157 | ;; ;; Note that these things _might_ be nested, with a capture list looking | ||
| 1158 | ;; ;; like: | ||
| 1159 | ;; ;; | ||
| 1160 | ;; ;; [ ...., &foo = [..](){...}(..), ... ] | ||
| 1161 | ;; ;; | ||
| 1162 | ;; ;; . What a wonderful language is C++. ;-) | ||
| 1163 | ;; (c-save-buffer-state (paren-state pos) | ||
| 1164 | ;; (goto-char c-new-BEG) | ||
| 1165 | ;; (setq paren-state (c-parse-state)) | ||
| 1166 | ;; (while (setq pos (c-pull-open-brace paren-state)) | ||
| 1167 | ;; (goto-char pos) | ||
| 1168 | ;; (when (c-looking-at-c++-lambda-capture-list) | ||
| 1169 | ;; (setq c-new-BEG (min c-new-BEG pos)) | ||
| 1170 | ;; (if (c-go-list-forward) | ||
| 1171 | ;; (setq c-new-END (max c-new-END (point)))))) | ||
| 1172 | |||
| 1173 | ;; (goto-char c-new-END) | ||
| 1174 | ;; (setq paren-state (c-parse-state)) | ||
| 1175 | ;; (while (setq pos (c-pull-open-brace paren-state)) | ||
| 1176 | ;; (goto-char pos) | ||
| 1177 | ;; (when (c-looking-at-c++-lambda-capture-list) | ||
| 1178 | ;; (setq c-new-BEG (min c-new-BEG pos)) | ||
| 1179 | ;; (if (c-go-list-forward) | ||
| 1180 | ;; (setq c-new-END (max c-new-END (point)))))))) | ||
| 1181 | 1299 | ||
| 1182 | (defun c-before-change (beg end) | 1300 | (defun c-before-change (beg end) |
| 1183 | ;; Function to be put on `before-change-functions'. Primarily, this calls | 1301 | ;; Function to be put on `before-change-functions'. Primarily, this calls |
diff --git a/lisp/progmodes/cc-styles.el b/lisp/progmodes/cc-styles.el index b3848a74f97..b1c94c3bc6a 100644 --- a/lisp/progmodes/cc-styles.el +++ b/lisp/progmodes/cc-styles.el | |||
| @@ -47,6 +47,7 @@ | |||
| 47 | ;; `c-add-style' often contains references to functions defined there. | 47 | ;; `c-add-style' often contains references to functions defined there. |
| 48 | 48 | ||
| 49 | ;; Silence the compiler. | 49 | ;; Silence the compiler. |
| 50 | (cc-bytecomp-defun c-guess-basic-syntax) | ||
| 50 | (cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs | 51 | (cc-bytecomp-defvar adaptive-fill-first-line-regexp) ; Emacs |
| 51 | 52 | ||
| 52 | 53 | ||
diff --git a/lisp/progmodes/tcl.el b/lisp/progmodes/tcl.el index 902a5aace08..de0cd50911a 100644 --- a/lisp/progmodes/tcl.el +++ b/lisp/progmodes/tcl.el | |||
| @@ -353,8 +353,6 @@ information): | |||
| 353 | Quotes all \"#\" characters that don't correspond to actual | 353 | Quotes all \"#\" characters that don't correspond to actual |
| 354 | Tcl comments. (Useful when editing code not originally created | 354 | Tcl comments. (Useful when editing code not originally created |
| 355 | with this mode). | 355 | with this mode). |
| 356 | `tcl-auto-fill-mode' | ||
| 357 | Auto-filling of Tcl comments. | ||
| 358 | 356 | ||
| 359 | Add functions to the hook with `add-hook': | 357 | Add functions to the hook with `add-hook': |
| 360 | 358 | ||
| @@ -1413,6 +1411,9 @@ Prefix argument means switch to the Tcl buffer afterwards." | |||
| 1413 | 1411 | ||
| 1414 | (defun tcl-auto-fill-mode (&optional arg) | 1412 | (defun tcl-auto-fill-mode (&optional arg) |
| 1415 | "Like `auto-fill-mode', but sets `comment-auto-fill-only-comments'." | 1413 | "Like `auto-fill-mode', but sets `comment-auto-fill-only-comments'." |
| 1414 | (declare | ||
| 1415 | (obsolete | ||
| 1416 | "Use `auto-fill-mode' with `comment-auto-fill-only-comments'." "26.1")) | ||
| 1416 | (interactive "P") | 1417 | (interactive "P") |
| 1417 | (auto-fill-mode arg) | 1418 | (auto-fill-mode arg) |
| 1418 | (if auto-fill-function | 1419 | (if auto-fill-function |
diff --git a/lisp/select.el b/lisp/select.el index 4849d7d515e..579c5c7e2ee 100644 --- a/lisp/select.el +++ b/lisp/select.el | |||
| @@ -475,6 +475,9 @@ two markers or an overlay. Otherwise, it is nil." | |||
| 475 | (t | 475 | (t |
| 476 | (error "Unknown selection type: %S" type))))) | 476 | (error "Unknown selection type: %S" type))))) |
| 477 | 477 | ||
| 478 | ;; Most programs are unable to handle NUL bytes in strings. | ||
| 479 | (setq str (replace-regexp-in-string "\0" "\\0" str t t)) | ||
| 480 | |||
| 478 | (setq next-selection-coding-system nil) | 481 | (setq next-selection-coding-system nil) |
| 479 | (cons type str)))) | 482 | (cons type str)))) |
| 480 | 483 | ||
diff --git a/lisp/ses.el b/lisp/ses.el index fd7174d383d..97bade380ec 100644 --- a/lisp/ses.el +++ b/lisp/ses.el | |||
| @@ -437,7 +437,7 @@ is nil if SYM is not a symbol that names a cell." | |||
| 437 | (declare (debug t)) | 437 | (declare (debug t)) |
| 438 | `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell)))) | 438 | `(let ((rc (and (symbolp ,sym) (get ,sym 'ses-cell)))) |
| 439 | (if (eq rc :ses-named) | 439 | (if (eq rc :ses-named) |
| 440 | (gethash ,sym ses--named-cell-hashmap) | 440 | (and ses--named-cell-hashmap (gethash ,sym ses--named-cell-hashmap)) |
| 441 | rc))) | 441 | rc))) |
| 442 | 442 | ||
| 443 | (defun ses-cell-p (cell) | 443 | (defun ses-cell-p (cell) |
| @@ -868,27 +868,39 @@ means Emacs will crash if FORMULA contains a circular list." | |||
| 868 | (oldref (ses-formula-references old)) | 868 | (oldref (ses-formula-references old)) |
| 869 | (newref (ses-formula-references formula)) | 869 | (newref (ses-formula-references formula)) |
| 870 | (inhibit-quit t) | 870 | (inhibit-quit t) |
| 871 | not-a-cell-ref-list | ||
| 871 | x xrow xcol) | 872 | x xrow xcol) |
| 872 | (cl-pushnew sym ses--deferred-recalc) | 873 | (cl-pushnew sym ses--deferred-recalc) |
| 873 | ;;Delete old references from this cell. Skip the ones that are also | 874 | ;;Delete old references from this cell. Skip the ones that are also |
| 874 | ;;in the new list. | 875 | ;;in the new list. |
| 875 | (dolist (ref oldref) | 876 | (dolist (ref oldref) |
| 876 | (unless (memq ref newref) | 877 | (unless (memq ref newref) |
| 877 | (setq x (ses-sym-rowcol ref) | 878 | ;; because we do not cancel edit when the user provides a |
| 878 | xrow (car x) | 879 | ;; false reference in it, then we need to check that ref |
| 879 | xcol (cdr x)) | 880 | ;; points to a cell that is within the spreadsheet. |
| 880 | (ses-set-cell xrow xcol 'references | 881 | (setq x (ses-sym-rowcol ref)) |
| 881 | (delq sym (ses-cell-references xrow xcol))))) | 882 | (and x |
| 883 | (< (setq xrow (car x)) ses--numrows) | ||
| 884 | (< (setq xcol (cdr x)) ses--numcols) | ||
| 885 | (ses-set-cell xrow xcol 'references | ||
| 886 | (delq sym (ses-cell-references xrow xcol)))))) | ||
| 882 | ;;Add new ones. Skip ones left over from old list | 887 | ;;Add new ones. Skip ones left over from old list |
| 883 | (dolist (ref newref) | 888 | (dolist (ref newref) |
| 884 | (setq x (ses-sym-rowcol ref) | 889 | (setq x (ses-sym-rowcol ref)) |
| 885 | xrow (car x) | 890 | ;;Do not trust the user, the reference may be outside the spreadsheet |
| 886 | xcol (cdr x) | 891 | (if (and |
| 887 | x (ses-cell-references xrow xcol)) | 892 | x |
| 888 | (or (memq sym x) | 893 | (< (setq xrow (car x)) ses--numrows) |
| 889 | (ses-set-cell xrow xcol 'references (cons sym x)))) | 894 | (< (setq xcol (cdr x)) ses--numcols)) |
| 895 | (progn | ||
| 896 | (setq x (ses-cell-references xrow xcol)) | ||
| 897 | (or (memq sym x) | ||
| 898 | (ses-set-cell xrow xcol 'references (cons sym x)))) | ||
| 899 | (cl-pushnew ref not-a-cell-ref-list))) | ||
| 890 | (ses-formula-record formula) | 900 | (ses-formula-record formula) |
| 891 | (ses-set-cell row col 'formula formula)))) | 901 | (ses-set-cell row col 'formula formula) |
| 902 | (and not-a-cell-ref-list | ||
| 903 | (error "Found in formula cells not in spreadsheet: %S" not-a-cell-ref-list))))) | ||
| 892 | 904 | ||
| 893 | 905 | ||
| 894 | (defun ses-repair-cell-reference-all () | 906 | (defun ses-repair-cell-reference-all () |
| @@ -1529,7 +1541,13 @@ by (ROWINCR,COLINCR)." | |||
| 1529 | ;;Relocate this variable, unless it is a named cell | 1541 | ;;Relocate this variable, unless it is a named cell |
| 1530 | (if (eq (get sym 'ses-cell) :ses-named) | 1542 | (if (eq (get sym 'ses-cell) :ses-named) |
| 1531 | sym | 1543 | sym |
| 1532 | (ses-create-cell-symbol row col)) | 1544 | ;; otherwise, we create the relocated cell symbol because |
| 1545 | ;; ses-cell-symbol gives the old symbols, however since | ||
| 1546 | ;; renamed cell are not relocated we keep the relocated | ||
| 1547 | ;; cell old symbol in this case. | ||
| 1548 | (if (eq (get (setq sym (ses-cell-symbol row col)) 'ses-cell) :ses-named) | ||
| 1549 | sym | ||
| 1550 | (ses-create-cell-symbol row col))) | ||
| 1533 | ;;Delete reference to a deleted cell | 1551 | ;;Delete reference to a deleted cell |
| 1534 | nil)))) | 1552 | nil)))) |
| 1535 | 1553 | ||
| @@ -2337,7 +2355,8 @@ to are recalculated first." | |||
| 2337 | "Recalculate and reprint all cells." | 2355 | "Recalculate and reprint all cells." |
| 2338 | (interactive "*") | 2356 | (interactive "*") |
| 2339 | (let ((startcell (ses--cell-at-pos (point))) | 2357 | (let ((startcell (ses--cell-at-pos (point))) |
| 2340 | (ses--curcell (cons 'A1 (ses-cell-symbol (1- ses--numrows) | 2358 | (ses--curcell (cons (ses-cell-symbol 0 0) |
| 2359 | (ses-cell-symbol (1- ses--numrows) | ||
| 2341 | (1- ses--numcols))))) | 2360 | (1- ses--numcols))))) |
| 2342 | (ses-recalculate-cell ses--curcell) | 2361 | (ses-recalculate-cell ses--curcell) |
| 2343 | (ses-jump-safe startcell))) | 2362 | (ses-jump-safe startcell))) |
diff --git a/lisp/subr.el b/lisp/subr.el index ef00286b341..a9edff6166f 100644 --- a/lisp/subr.el +++ b/lisp/subr.el | |||
| @@ -121,6 +121,7 @@ BODY should be a list of Lisp expressions. | |||
| 121 | (defmacro setq-local (var val) | 121 | (defmacro setq-local (var val) |
| 122 | "Set variable VAR to value VAL in current buffer." | 122 | "Set variable VAR to value VAL in current buffer." |
| 123 | ;; Can't use backquote here, it's too early in the bootstrap. | 123 | ;; Can't use backquote here, it's too early in the bootstrap. |
| 124 | (declare (debug (symbolp form))) | ||
| 124 | (list 'set (list 'make-local-variable (list 'quote var)) val)) | 125 | (list 'set (list 'make-local-variable (list 'quote var)) val)) |
| 125 | 126 | ||
| 126 | (defmacro defvar-local (var val &optional docstring) | 127 | (defmacro defvar-local (var val &optional docstring) |
| @@ -4513,7 +4514,8 @@ EVALD, FUNC, ARGS, FLAGS are as in `mapbacktrace'." | |||
| 4513 | (defun backtrace () | 4514 | (defun backtrace () |
| 4514 | "Print a trace of Lisp function calls currently active. | 4515 | "Print a trace of Lisp function calls currently active. |
| 4515 | Output stream used is value of `standard-output'." | 4516 | Output stream used is value of `standard-output'." |
| 4516 | (let ((print-level (or print-level 8))) | 4517 | (let ((print-level (or print-level 8)) |
| 4518 | (print-escape-control-characters t)) | ||
| 4517 | (mapbacktrace #'backtrace--print-frame 'backtrace))) | 4519 | (mapbacktrace #'backtrace--print-frame 'backtrace))) |
| 4518 | 4520 | ||
| 4519 | (defun backtrace-frames (&optional base) | 4521 | (defun backtrace-frames (&optional base) |
diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index fda93884c40..be895a040da 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el | |||
| @@ -396,7 +396,7 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") | |||
| 396 | ;;; Fix interface to (X-specific) mouse.el | 396 | ;;; Fix interface to (X-specific) mouse.el |
| 397 | (defun w32--set-selection (type value) | 397 | (defun w32--set-selection (type value) |
| 398 | (if (eq type 'CLIPBOARD) | 398 | (if (eq type 'CLIPBOARD) |
| 399 | (w32-set-clipboard-data value) | 399 | (w32-set-clipboard-data (replace-regexp-in-string "\0" "\\0" value t t)) |
| 400 | (put 'x-selections (or type 'PRIMARY) value))) | 400 | (put 'x-selections (or type 'PRIMARY) value))) |
| 401 | 401 | ||
| 402 | (defun w32--get-selection (&optional type data-type) | 402 | (defun w32--get-selection (&optional type data-type) |
diff --git a/lisp/tooltip.el b/lisp/tooltip.el index 367114b83f5..c011f1b01bc 100644 --- a/lisp/tooltip.el +++ b/lisp/tooltip.el | |||
| @@ -119,7 +119,8 @@ the value of `tooltip-y-offset' is ignored." | |||
| 119 | (defcustom tooltip-frame-parameters | 119 | (defcustom tooltip-frame-parameters |
| 120 | '((name . "tooltip") | 120 | '((name . "tooltip") |
| 121 | (internal-border-width . 2) | 121 | (internal-border-width . 2) |
| 122 | (border-width . 1)) | 122 | (border-width . 1) |
| 123 | (no-special-glyphs . t)) | ||
| 123 | "Frame parameters used for tooltips. | 124 | "Frame parameters used for tooltips. |
| 124 | 125 | ||
| 125 | If `left' or `top' parameters are included, they specify the absolute | 126 | If `left' or `top' parameters are included, they specify the absolute |
| @@ -130,7 +131,8 @@ of the `tooltip' face are used instead." | |||
| 130 | :type '(repeat (cons :format "%v" | 131 | :type '(repeat (cons :format "%v" |
| 131 | (symbol :tag "Parameter") | 132 | (symbol :tag "Parameter") |
| 132 | (sexp :tag "Value"))) | 133 | (sexp :tag "Value"))) |
| 133 | :group 'tooltip) | 134 | :group 'tooltip |
| 135 | :version "26.1") | ||
| 134 | 136 | ||
| 135 | (defface tooltip | 137 | (defface tooltip |
| 136 | '((((class color)) | 138 | '((((class color)) |
diff --git a/lisp/url/url-history.el b/lisp/url/url-history.el index 1fa085400d8..8657d19da8c 100644 --- a/lisp/url/url-history.el +++ b/lisp/url/url-history.el | |||
| @@ -1,4 +1,4 @@ | |||
| 1 | ;;; url-history.el --- Global history tracking for URL package | 1 | ;;; url-history.el --- Global history tracking for URL package -*- lexical-binding:t -*- |
| 2 | 2 | ||
| 3 | ;; Copyright (C) 1996-1999, 2004-2017 Free Software Foundation, Inc. | 3 | ;; Copyright (C) 1996-1999, 2004-2017 Free Software Foundation, Inc. |
| 4 | 4 | ||
| @@ -106,7 +106,7 @@ to run the `url-history-setup-save-timer' function manually." | |||
| 106 | 106 | ||
| 107 | (defun url-history-update-url (url time) | 107 | (defun url-history-update-url (url time) |
| 108 | (setq url-history-changed-since-last-save t) | 108 | (setq url-history-changed-since-last-save t) |
| 109 | (puthash (if (vectorp url) (url-recreate-url url) url) time | 109 | (puthash (if (url-p url) (url-recreate-url url) url) time |
| 110 | url-history-hash-table)) | 110 | url-history-hash-table)) |
| 111 | 111 | ||
| 112 | (autoload 'url-make-private-file "url-util") | 112 | (autoload 'url-make-private-file "url-util") |
| @@ -157,6 +157,7 @@ user for what type to save as." | |||
| 157 | (gethash url url-history-hash-table nil)) | 157 | (gethash url url-history-hash-table nil)) |
| 158 | 158 | ||
| 159 | (defun url-completion-function (string predicate function) | 159 | (defun url-completion-function (string predicate function) |
| 160 | (declare (obsolete url-history-hash-table "26.1")) | ||
| 160 | ;; Completion function to complete urls from the history. | 161 | ;; Completion function to complete urls from the history. |
| 161 | ;; This is obsolete since we can now pass the hash-table directly as a | 162 | ;; This is obsolete since we can now pass the hash-table directly as a |
| 162 | ;; completion table. | 163 | ;; completion table. |
| @@ -164,7 +165,7 @@ user for what type to save as." | |||
| 164 | (cond | 165 | (cond |
| 165 | ((eq function nil) | 166 | ((eq function nil) |
| 166 | (let ((list nil)) | 167 | (let ((list nil)) |
| 167 | (maphash (lambda (key val) (push key list)) | 168 | (maphash (lambda (key _) (push key list)) |
| 168 | url-history-hash-table) | 169 | url-history-hash-table) |
| 169 | ;; Not sure why we bother reversing the list. --Stef | 170 | ;; Not sure why we bother reversing the list. --Stef |
| 170 | (try-completion string (nreverse list) predicate))) | 171 | (try-completion string (nreverse list) predicate))) |
| @@ -172,7 +173,7 @@ user for what type to save as." | |||
| 172 | (let ((stub (concat "\\`" (regexp-quote string))) | 173 | (let ((stub (concat "\\`" (regexp-quote string))) |
| 173 | (retval nil)) | 174 | (retval nil)) |
| 174 | (maphash | 175 | (maphash |
| 175 | (lambda (url time) | 176 | (lambda (url _) |
| 176 | (if (string-match stub url) (push url retval))) | 177 | (if (string-match stub url) (push url retval))) |
| 177 | url-history-hash-table) | 178 | url-history-hash-table) |
| 178 | retval)) | 179 | retval)) |
diff --git a/lisp/window.el b/lisp/window.el index 8b07ed462c9..c933996a72f 100644 --- a/lisp/window.el +++ b/lisp/window.el | |||
| @@ -3703,7 +3703,7 @@ are one more than the actual value of these edges. Note that if | |||
| 3703 | ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too." | 3703 | ABSOLUTE is non-nil, PIXELWISE is implicitly non-nil too." |
| 3704 | (let* ((window (window-normalize-window window body)) | 3704 | (let* ((window (window-normalize-window window body)) |
| 3705 | (frame (window-frame window)) | 3705 | (frame (window-frame window)) |
| 3706 | (border-width (frame-border-width frame)) | 3706 | (border-width (frame-internal-border-width frame)) |
| 3707 | (char-width (frame-char-width frame)) | 3707 | (char-width (frame-char-width frame)) |
| 3708 | (char-height (frame-char-height frame)) | 3708 | (char-height (frame-char-height frame)) |
| 3709 | (left (if pixelwise | 3709 | (left (if pixelwise |
| @@ -4572,12 +4572,13 @@ The function is called with one argument - a frame. | |||
| 4572 | Functions affected by this option are those that bury a buffer | 4572 | Functions affected by this option are those that bury a buffer |
| 4573 | shown in a separate frame like `quit-window' and `bury-buffer'." | 4573 | shown in a separate frame like `quit-window' and `bury-buffer'." |
| 4574 | :type '(choice (const :tag "Iconify" iconify-frame) | 4574 | :type '(choice (const :tag "Iconify" iconify-frame) |
| 4575 | (const :tag "Make invisible" make-frame-invisible) | ||
| 4575 | (const :tag "Delete" delete-frame) | 4576 | (const :tag "Delete" delete-frame) |
| 4576 | (const :tag "Do nothing" ignore) | 4577 | (const :tag "Do nothing" ignore) |
| 4577 | function) | 4578 | function) |
| 4578 | :group 'windows | 4579 | :group 'windows |
| 4579 | :group 'frames | 4580 | :group 'frames |
| 4580 | :version "24.1") | 4581 | :version "26.1") |
| 4581 | 4582 | ||
| 4582 | (defun window--delete (&optional window dedicated-only kill) | 4583 | (defun window--delete (&optional window dedicated-only kill) |
| 4583 | "Delete WINDOW if possible. | 4584 | "Delete WINDOW if possible. |
| @@ -4595,7 +4596,9 @@ if WINDOW gets deleted or its frame is auto-hidden." | |||
| 4595 | (cond | 4596 | (cond |
| 4596 | (kill | 4597 | (kill |
| 4597 | (delete-frame frame)) | 4598 | (delete-frame frame)) |
| 4598 | ((functionp frame-auto-hide-function) | 4599 | ((functionp (frame-parameter frame 'auto-hide-function)) |
| 4600 | (funcall (frame-parameter frame 'auto-hide-function))) | ||
| 4601 | ((functionp frame-auto-hide-function) | ||
| 4599 | (funcall frame-auto-hide-function frame)))) | 4602 | (funcall frame-auto-hide-function frame)))) |
| 4600 | 'frame) | 4603 | 'frame) |
| 4601 | (deletable | 4604 | (deletable |
| @@ -6734,15 +6737,17 @@ live." | |||
| 6734 | window)) | 6737 | window)) |
| 6735 | 6738 | ||
| 6736 | (defun window--maybe-raise-frame (frame) | 6739 | (defun window--maybe-raise-frame (frame) |
| 6737 | (let ((visible (frame-visible-p frame))) | 6740 | (make-frame-visible frame) |
| 6738 | (unless (or (not visible) | 6741 | (unless (or (frame-parameter frame 'no-focus-on-map) |
| 6739 | ;; Assume the selected frame is already visible enough. | 6742 | ;; Don't raise frames that should not get focus. |
| 6740 | (eq frame (selected-frame)) | 6743 | (frame-parameter frame 'no-accept-focus) |
| 6741 | ;; Assume the frame from which we invoked the | 6744 | ;; Assume the selected frame is already visible enough. |
| 6742 | ;; minibuffer is visible. | 6745 | (eq frame (selected-frame)) |
| 6743 | (and (minibuffer-window-active-p (selected-window)) | 6746 | ;; Assume the frame from which we invoked the |
| 6744 | (eq frame (window-frame (minibuffer-selected-window))))) | 6747 | ;; minibuffer is visible. |
| 6745 | (raise-frame frame)))) | 6748 | (and (minibuffer-window-active-p (selected-window)) |
| 6749 | (eq frame (window-frame (minibuffer-selected-window))))) | ||
| 6750 | (raise-frame frame))) | ||
| 6746 | 6751 | ||
| 6747 | ;; FIXME: Not implemented. | 6752 | ;; FIXME: Not implemented. |
| 6748 | ;; FIXME: By the way, there could be more levels of dedication: | 6753 | ;; FIXME: By the way, there could be more levels of dedication: |
| @@ -6762,6 +6767,7 @@ The actual non-nil value of this variable will be copied to the | |||
| 6762 | (const display-buffer-pop-up-window) | 6767 | (const display-buffer-pop-up-window) |
| 6763 | (const display-buffer-same-window) | 6768 | (const display-buffer-same-window) |
| 6764 | (const display-buffer-pop-up-frame) | 6769 | (const display-buffer-pop-up-frame) |
| 6770 | (const display-buffer-in-child-frame) | ||
| 6765 | (const display-buffer-below-selected) | 6771 | (const display-buffer-below-selected) |
| 6766 | (const display-buffer-at-bottom) | 6772 | (const display-buffer-at-bottom) |
| 6767 | (const display-buffer-in-previous-window) | 6773 | (const display-buffer-in-previous-window) |
| @@ -6908,6 +6914,7 @@ Available action functions include: | |||
| 6908 | `display-buffer-same-window' | 6914 | `display-buffer-same-window' |
| 6909 | `display-buffer-reuse-window' | 6915 | `display-buffer-reuse-window' |
| 6910 | `display-buffer-pop-up-frame' | 6916 | `display-buffer-pop-up-frame' |
| 6917 | `display-buffer-in-child-frame' | ||
| 6911 | `display-buffer-pop-up-window' | 6918 | `display-buffer-pop-up-window' |
| 6912 | `display-buffer-in-previous-window' | 6919 | `display-buffer-in-previous-window' |
| 6913 | `display-buffer-use-some-window' | 6920 | `display-buffer-use-some-window' |
| @@ -7239,6 +7246,7 @@ raising the frame." | |||
| 7239 | (get-largest-window frame t) alist) | 7246 | (get-largest-window frame t) alist) |
| 7240 | (window--try-to-split-window | 7247 | (window--try-to-split-window |
| 7241 | (get-lru-window frame t) alist)))) | 7248 | (get-lru-window frame t) alist)))) |
| 7249 | |||
| 7242 | (prog1 (window--display-buffer | 7250 | (prog1 (window--display-buffer |
| 7243 | buffer window 'window alist display-buffer-mark-dedicated) | 7251 | buffer window 'window alist display-buffer-mark-dedicated) |
| 7244 | (unless (cdr (assq 'inhibit-switch-frame alist)) | 7252 | (unless (cdr (assq 'inhibit-switch-frame alist)) |
| @@ -7258,6 +7266,47 @@ again with `display-buffer-pop-up-window'." | |||
| 7258 | (and pop-up-windows | 7266 | (and pop-up-windows |
| 7259 | (display-buffer-pop-up-window buffer alist)))) | 7267 | (display-buffer-pop-up-window buffer alist)))) |
| 7260 | 7268 | ||
| 7269 | (defun display-buffer-in-child-frame (buffer alist) | ||
| 7270 | "Display BUFFER in a child frame. | ||
| 7271 | By default, this either reuses a child frame of the selected | ||
| 7272 | frame or makes a new child frame of the selected frame. If | ||
| 7273 | successful, return the window used; otherwise return nil. | ||
| 7274 | |||
| 7275 | If ALIST has a non-nil 'child-frame-parameters' entry, the | ||
| 7276 | corresponding value is an alist of frame parameters to give the | ||
| 7277 | new frame. A 'parent-frame' parameter specifying the selected | ||
| 7278 | frame is provided by default. If the child frame should be or | ||
| 7279 | become the child of any other frame, a corresponding entry must | ||
| 7280 | be added to ALIST." | ||
| 7281 | (let* ((parameters | ||
| 7282 | (append | ||
| 7283 | (cdr (assq 'child-frame-parameters alist)) | ||
| 7284 | `((parent-frame . ,(selected-frame))))) | ||
| 7285 | (parent (or (assq 'parent-frame parameters) | ||
| 7286 | (selected-frame))) | ||
| 7287 | (share (assq 'share-child-frame parameters)) | ||
| 7288 | share1 frame window) | ||
| 7289 | (with-current-buffer buffer | ||
| 7290 | (when (frame-live-p parent) | ||
| 7291 | (catch 'frame | ||
| 7292 | (dolist (frame1 (frame-list)) | ||
| 7293 | (when (eq (frame-parent frame1) parent) | ||
| 7294 | (setq share1 (assq 'share-child-frame | ||
| 7295 | (frame-parameters frame1))) | ||
| 7296 | (when (eq share share1) | ||
| 7297 | (setq frame frame1) | ||
| 7298 | (throw 'frame t)))))) | ||
| 7299 | |||
| 7300 | (if frame | ||
| 7301 | (setq window (frame-selected-window frame)) | ||
| 7302 | (setq frame (make-frame parameters)) | ||
| 7303 | (setq window (frame-selected-window frame)))) | ||
| 7304 | |||
| 7305 | (prog1 (window--display-buffer | ||
| 7306 | buffer window 'frame alist display-buffer-mark-dedicated) | ||
| 7307 | (unless (cdr (assq 'inhibit-switch-frame alist)) | ||
| 7308 | (window--maybe-raise-frame frame))))) | ||
| 7309 | |||
| 7261 | (defun display-buffer-below-selected (buffer alist) | 7310 | (defun display-buffer-below-selected (buffer alist) |
| 7262 | "Try displaying BUFFER in a window below the selected window. | 7311 | "Try displaying BUFFER in a window below the selected window. |
| 7263 | If there is a window below the selected one and that window | 7312 | If there is a window below the selected one and that window |
| @@ -7272,7 +7321,8 @@ below the selected one, use that window." | |||
| 7272 | (and (not (frame-parameter nil 'unsplittable)) | 7321 | (and (not (frame-parameter nil 'unsplittable)) |
| 7273 | (let ((split-height-threshold 0) | 7322 | (let ((split-height-threshold 0) |
| 7274 | split-width-threshold) | 7323 | split-width-threshold) |
| 7275 | (setq window (window--try-to-split-window (selected-window) alist))) | 7324 | (setq window (window--try-to-split-window |
| 7325 | (selected-window) alist))) | ||
| 7276 | (window--display-buffer | 7326 | (window--display-buffer |
| 7277 | buffer window 'window alist display-buffer-mark-dedicated)) | 7327 | buffer window 'window alist display-buffer-mark-dedicated)) |
| 7278 | (and (setq window (window-in-direction 'below)) | 7328 | (and (setq window (window-in-direction 'below)) |
| @@ -7885,10 +7935,12 @@ See also `fit-frame-to-buffer-margins'." | |||
| 7885 | (declare-function x-display-pixel-height "xfns.c" (&optional terminal)) | 7935 | (declare-function x-display-pixel-height "xfns.c" (&optional terminal)) |
| 7886 | 7936 | ||
| 7887 | (defun window--sanitize-margin (margin left right) | 7937 | (defun window--sanitize-margin (margin left right) |
| 7888 | "Return MARGIN if it's a number between LEFT and RIGHT." | 7938 | "Return MARGIN if it's a number between LEFT and RIGHT. |
| 7889 | (when (and (numberp margin) | 7939 | Return 0 otherwise." |
| 7890 | (<= left (- right margin)) (<= margin right)) | 7940 | (if (and (numberp margin) |
| 7891 | margin)) | 7941 | (<= left (- right margin)) (<= margin right)) |
| 7942 | margin | ||
| 7943 | 0)) | ||
| 7892 | 7944 | ||
| 7893 | (declare-function tool-bar-height "xdisp.c" (&optional frame pixelwise)) | 7945 | (declare-function tool-bar-height "xdisp.c" (&optional frame pixelwise)) |
| 7894 | 7946 | ||
| @@ -7906,190 +7958,197 @@ horizontally only. | |||
| 7906 | 7958 | ||
| 7907 | The new position and size of FRAME can be additionally determined | 7959 | The new position and size of FRAME can be additionally determined |
| 7908 | by customizing the options `fit-frame-to-buffer-sizes' and | 7960 | by customizing the options `fit-frame-to-buffer-sizes' and |
| 7909 | `fit-frame-to-buffer-margins' or the corresponding parameters of | 7961 | `fit-frame-to-buffer-margins' or setting the corresponding |
| 7910 | FRAME." | 7962 | parameters of FRAME." |
| 7911 | (interactive) | 7963 | (interactive) |
| 7912 | (unless (and (fboundp 'x-display-pixel-height) | 7964 | (unless (fboundp 'display-monitor-attributes-list) |
| 7913 | ;; We need the respective sizes now. | ||
| 7914 | (fboundp 'display-monitor-attributes-list)) | ||
| 7915 | (user-error "Cannot resize frame in non-graphic Emacs")) | 7965 | (user-error "Cannot resize frame in non-graphic Emacs")) |
| 7916 | (setq frame (window-normalize-frame frame)) | 7966 | (setq frame (window-normalize-frame frame)) |
| 7917 | (when (window-live-p (frame-root-window frame)) | 7967 | (when (window-live-p (frame-root-window frame)) |
| 7918 | (with-selected-window (frame-root-window frame) | 7968 | (let* ((char-width (frame-char-width frame)) |
| 7919 | (let* ((char-width (frame-char-width)) | 7969 | (char-height (frame-char-height frame)) |
| 7920 | (char-height (frame-char-height)) | 7970 | ;; WINDOW is FRAME's root window. |
| 7921 | (monitor-attributes (car (display-monitor-attributes-list | 7971 | (window (frame-root-window frame)) |
| 7922 | (frame-parameter frame 'display)))) | 7972 | (parent (frame-parent frame)) |
| 7923 | (geometry (cdr (assq 'geometry monitor-attributes))) | 7973 | (monitor-attributes |
| 7924 | (display-width (- (nth 2 geometry) (nth 0 geometry))) | 7974 | (unless parent |
| 7925 | (display-height (- (nth 3 geometry) (nth 1 geometry))) | 7975 | (car (display-monitor-attributes-list |
| 7926 | (workarea (cdr (assq 'workarea monitor-attributes))) | 7976 | (frame-parameter frame 'display))))) |
| 7927 | ;; Handle margins. | 7977 | ;; FRAME'S parent or display sizes. Used in connection |
| 7928 | (margins (or (frame-parameter frame 'fit-frame-to-buffer-margins) | 7978 | ;; with margins. |
| 7929 | fit-frame-to-buffer-margins)) | 7979 | (geometry |
| 7930 | (left-margin (if (nth 0 margins) | 7980 | (unless parent |
| 7931 | (or (window--sanitize-margin | 7981 | (cdr (assq 'geometry monitor-attributes)))) |
| 7932 | (nth 0 margins) 0 display-width) | 7982 | (parent-or-display-width |
| 7933 | 0) | 7983 | (if parent |
| 7934 | (nth 0 workarea))) | 7984 | (frame-native-width parent) |
| 7935 | (top-margin (if (nth 1 margins) | 7985 | (- (nth 2 geometry) (nth 0 geometry)))) |
| 7936 | (or (window--sanitize-margin | 7986 | (parent-or-display-height |
| 7937 | (nth 1 margins) 0 display-height) | 7987 | (if parent |
| 7938 | 0) | 7988 | (frame-native-height parent) |
| 7939 | (nth 1 workarea))) | 7989 | (- (nth 3 geometry) (nth 1 geometry)))) |
| 7940 | (workarea-width (nth 2 workarea)) | 7990 | ;; FRAME'S parent or workarea sizes. Used when no margins |
| 7941 | (right-margin (if (nth 2 margins) | 7991 | ;; are specified. |
| 7942 | (- display-width | 7992 | (parent-or-workarea |
| 7943 | (or (window--sanitize-margin | 7993 | (if parent |
| 7944 | (nth 2 margins) left-margin display-width) | 7994 | `(0 0 ,parent-or-display-width ,parent-or-display-height) |
| 7945 | 0)) | 7995 | (cdr (assq 'workarea monitor-attributes)))) |
| 7946 | (nth 2 workarea))) | 7996 | ;; The outer size of FRAME. Needed to calculate the |
| 7947 | (workarea-height (nth 3 workarea)) | 7997 | ;; margins around the root window's body that have to |
| 7948 | (bottom-margin (if (nth 3 margins) | 7998 | ;; remain untouched by fitting. |
| 7949 | (- display-height | 7999 | (outer-edges (frame-edges frame 'outer-edges)) |
| 7950 | (or (window--sanitize-margin | 8000 | (outer-width (if outer-edges |
| 7951 | (nth 3 margins) top-margin display-height) | 8001 | (- (nth 2 outer-edges) (nth 0 outer-edges)) |
| 7952 | 0)) | 8002 | ;; A poor guess. |
| 7953 | (nth 3 workarea))) | 8003 | (frame-pixel-width frame))) |
| 7954 | ;; The pixel width of FRAME (which does not include the | 8004 | (outer-height (if outer-edges |
| 7955 | ;; window manager's decorations). | 8005 | (- (nth 3 outer-edges) (nth 1 outer-edges)) |
| 7956 | (frame-width (frame-pixel-width)) | 8006 | ;; Another poor guess. |
| 7957 | ;; The pixel width of the body of FRAME's root window. | 8007 | (frame-pixel-height frame))) |
| 7958 | (window-body-width (window-body-width nil t)) | 8008 | ;; The text size of of FRAME. Needed to specify FRAME's |
| 7959 | ;; The difference in pixels between total and body width of | 8009 | ;; text size after the root window's body's new sizes have |
| 7960 | ;; FRAME's window. | 8010 | ;; been calculated. |
| 7961 | (window-extra-width (- (window-pixel-width) window-body-width)) | 8011 | (text-width (frame-text-width frame)) |
| 7962 | ;; The difference in pixels between the frame's pixel width | 8012 | (text-height (frame-text-height frame)) |
| 7963 | ;; and the window's body width. This is the space we can't | 8013 | ;; WINDOW's body size. |
| 7964 | ;; use for fitting. | 8014 | (body-width (window-body-width window t)) |
| 7965 | (extra-width (- frame-width window-body-width)) | 8015 | (body-height (window-body-height window t)) |
| 7966 | ;; The pixel position of FRAME's left border. We usually | 8016 | ;; The difference between FRAME's outer size and WINDOW's |
| 7967 | ;; try to leave this alone. | 8017 | ;; body size. |
| 7968 | (left | 8018 | (outer-minus-body-width (- outer-width body-width)) |
| 7969 | (let ((left (frame-parameter nil 'left))) | 8019 | (outer-minus-body-height (- outer-height body-height)) |
| 7970 | (if (consp left) | 8020 | ;; The difference between FRAME's text size and WINDOW's |
| 7971 | (funcall (car left) (cadr left)) | 8021 | ;; body size (these values "should" be positive). |
| 7972 | left))) | 8022 | (text-minus-body-width (- text-width body-width)) |
| 7973 | ;; The pixel height of FRAME (which does not include title | 8023 | (text-minus-body-height (- text-height body-height)) |
| 7974 | ;; line, decorations, and sometimes neither the menu nor | 8024 | ;; The current position of FRAME. |
| 7975 | ;; the toolbar). | 8025 | (position (frame-position frame)) |
| 7976 | (frame-height (frame-pixel-height)) | 8026 | (left (car position)) |
| 7977 | ;; The pixel height of FRAME's root window (we don't care | 8027 | (top (cdr position)) |
| 7978 | ;; about the window's body height since the return value of | 8028 | ;; The margins specified for FRAME. These represent pixel |
| 7979 | ;; `window-text-pixel-size' includes header and mode line). | 8029 | ;; offsets from the left, top, right and bottom edge of the |
| 7980 | (window-height (window-pixel-height)) | 8030 | ;; display or FRAME's parent's native rectangle and have to |
| 7981 | ;; The difference in pixels between the frame's pixel | 8031 | ;; take care of the display's taskbar and other obstacles. |
| 7982 | ;; height and the window's height. | 8032 | ;; If they are unspecified, constrain the resulting frame |
| 7983 | (extra-height (- frame-height window-height)) | 8033 | ;; to its workarea or the parent frame's native rectangle. |
| 7984 | ;; The pixel position of FRAME's top border. | 8034 | (margins (or (frame-parameter frame 'fit-frame-to-buffer-margins) |
| 7985 | (top | 8035 | fit-frame-to-buffer-margins)) |
| 7986 | (let ((top (frame-parameter nil 'top))) | 8036 | ;; Convert margins intto pixel offsets from the left-top |
| 7987 | (if (consp top) | 8037 | ;; corner of FRAME's display or parent. |
| 7988 | (funcall (car top) (cadr top)) | 8038 | (left-margin (if (nth 0 margins) |
| 7989 | top))) | 8039 | (window--sanitize-margin |
| 7990 | ;; Sanitize minimum and maximum sizes. | 8040 | (nth 0 margins) 0 parent-or-display-width) |
| 7991 | (sizes (or (frame-parameter frame 'fit-frame-to-buffer-sizes) | 8041 | (nth 0 parent-or-workarea))) |
| 7992 | fit-frame-to-buffer-sizes)) | 8042 | (top-margin (if (nth 1 margins) |
| 7993 | (max-height | 8043 | (window--sanitize-margin |
| 7994 | (cond | 8044 | (nth 1 margins) 0 parent-or-display-height) |
| 7995 | ((numberp (nth 0 sizes)) (* (nth 0 sizes) char-height)) | 8045 | (nth 1 parent-or-workarea))) |
| 7996 | ((numberp max-height) (* max-height char-height)) | 8046 | (right-margin (if (nth 2 margins) |
| 7997 | (t display-height))) | 8047 | (- parent-or-display-width |
| 7998 | (min-height | 8048 | (window--sanitize-margin |
| 7999 | (cond | 8049 | (nth 2 margins) left-margin |
| 8000 | ((numberp (nth 1 sizes)) (* (nth 1 sizes) char-height)) | 8050 | parent-or-display-width)) |
| 8001 | ((numberp min-height) (* min-height char-height)) | 8051 | (nth 2 parent-or-workarea))) |
| 8002 | (t (* window-min-height char-height)))) | 8052 | (bottom-margin (if (nth 3 margins) |
| 8003 | (max-width | 8053 | (- parent-or-display-height |
| 8004 | (cond | 8054 | (window--sanitize-margin |
| 8005 | ((numberp (nth 2 sizes)) | 8055 | (nth 3 margins) top-margin |
| 8006 | (- (* (nth 2 sizes) char-width) window-extra-width)) | 8056 | parent-or-display-height)) |
| 8007 | ((numberp max-width) | 8057 | (nth 3 parent-or-workarea))) |
| 8008 | (- (* max-width char-width) window-extra-width)) | 8058 | ;; Minimum and maximum sizes specified for FRAME. |
| 8009 | (t display-width))) | 8059 | (sizes (or (frame-parameter frame 'fit-frame-to-buffer-sizes) |
| 8010 | (min-width | 8060 | fit-frame-to-buffer-sizes)) |
| 8011 | (cond | 8061 | ;; Calculate the minimum and maximum pixel sizes of FRAME |
| 8012 | ((numberp (nth 3 sizes)) | 8062 | ;; from the values provided by the MAX-HEIGHT, MIN-HEIGHT, |
| 8013 | (- (* (nth 3 sizes) char-width) window-extra-width)) | 8063 | ;; MAX-WIDTH and MIN-WIDTH arguments or, if these are nil, |
| 8014 | ((numberp min-width) | 8064 | ;; from those provided by `fit-frame-to-buffer-sizes'. |
| 8015 | (- (* min-width char-width) window-extra-width)) | 8065 | (max-height |
| 8016 | (t (* window-min-width char-width)))) | 8066 | (min |
| 8017 | ;; Note: Currently, for a new frame the sizes of the header | 8067 | (cond |
| 8018 | ;; and mode line may be estimated incorrectly | 8068 | ((numberp max-height) (* max-height char-height)) |
| 8019 | (value (window-text-pixel-size | 8069 | ((numberp (nth 0 sizes)) (* (nth 0 sizes) char-height)) |
| 8020 | nil t t workarea-width workarea-height t)) | 8070 | (t parent-or-display-height)) |
| 8021 | (width (+ (car value) (window-right-divider-width))) | 8071 | ;; The following is the maximum height that fits into the |
| 8022 | (height | 8072 | ;; top and bottom margins. |
| 8023 | (+ (cdr value) | 8073 | (max (- bottom-margin top-margin outer-minus-body-height)))) |
| 8024 | (window-bottom-divider-width) | 8074 | (min-height |
| 8025 | (window-scroll-bar-height)))) | 8075 | (cond |
| 8026 | ;; Don't change height or width when the window's size is fixed | 8076 | ((numberp min-height) (* min-height char-height)) |
| 8027 | ;; in either direction or ONLY forbids it. | 8077 | ((numberp (nth 1 sizes)) (* (nth 1 sizes) char-height)) |
| 8028 | (cond | 8078 | (t (window-min-size window nil nil t)))) |
| 8029 | ((or (eq window-size-fixed 'width) (eq only 'vertically)) | 8079 | (max-width |
| 8030 | (setq width nil)) | 8080 | (min |
| 8031 | ((or (eq window-size-fixed 'height) (eq only 'horizontally)) | 8081 | (cond |
| 8032 | (setq height nil))) | 8082 | ((numberp max-width) (* max-width char-width)) |
| 8033 | ;; Fit width to constraints. | 8083 | ((numberp (nth 2 sizes)) (* (nth 2 sizes) char-width)) |
| 8034 | (when width | 8084 | (t parent-or-display-width)) |
| 8035 | (unless frame-resize-pixelwise | 8085 | ;; The following is the maximum width that fits into the |
| 8036 | ;; Round to character sizes. | 8086 | ;; left and right margins. |
| 8037 | (setq width (* (/ (+ width char-width -1) char-width) | 8087 | (max (- right-margin left-margin outer-minus-body-width)))) |
| 8038 | char-width))) | 8088 | (min-width |
| 8039 | ;; Fit to maximum and minimum widths. | 8089 | (cond |
| 8040 | (setq width (max (min width max-width) min-width)) | 8090 | ((numberp min-width) (* min-width char-width)) |
| 8041 | ;; Add extra width. | 8091 | ((numberp (nth 3 sizes)) (nth 3 sizes)) |
| 8042 | (setq width (+ width extra-width)) | 8092 | (t (window-min-size window t nil t)))) |
| 8043 | ;; Preserve margins. | 8093 | ;; Note: Currently, for a new frame the sizes of the header |
| 8044 | (let ((right (+ left width))) | 8094 | ;; and mode line may be estimated incorrectly |
| 8045 | (cond | 8095 | (size |
| 8046 | ((> right right-margin) | 8096 | (window-text-pixel-size window t t max-width max-height)) |
| 8047 | ;; Move frame to left (we don't know its real width). | 8097 | (width (max (car size) min-width)) |
| 8048 | (setq left (max left-margin (- left (- right right-margin))))) | 8098 | (height (max (cdr size) min-height))) |
| 8049 | ((< left left-margin) | 8099 | ;; Don't change height or width when the window's size is fixed |
| 8050 | ;; Move frame to right. | 8100 | ;; in either direction or ONLY forbids it. |
| 8051 | (setq left left-margin))))) | 8101 | (cond |
| 8052 | ;; Fit height to constraints. | 8102 | ((or (eq window-size-fixed 'width) (eq only 'vertically)) |
| 8053 | (when height | 8103 | (setq width nil)) |
| 8054 | (unless frame-resize-pixelwise | 8104 | ((or (eq window-size-fixed 'height) (eq only 'horizontally)) |
| 8055 | (setq height (* (/ (+ height char-height -1) char-height) | 8105 | (setq height nil))) |
| 8056 | char-height))) | 8106 | ;; Fit width to constraints. |
| 8057 | ;; Fit to maximum and minimum heights. | 8107 | (when width |
| 8058 | (setq height (max (min height max-height) min-height)) | 8108 | (unless frame-resize-pixelwise |
| 8059 | ;; Add extra height. | 8109 | ;; Round to character sizes. |
| 8060 | (setq height (+ height extra-height)) | 8110 | (setq width (* (/ (+ width char-width -1) char-width) |
| 8061 | ;; Preserve margins. | 8111 | char-width))) |
| 8062 | (let ((bottom (+ top height))) | 8112 | ;; The new outer width (in pixels). |
| 8063 | (cond | 8113 | (setq outer-width (+ width outer-minus-body-width)) |
| 8064 | ((> bottom bottom-margin) | 8114 | ;; Maybe move FRAME to preserve margins. |
| 8065 | ;; Move frame up (we don't know its real height). | 8115 | (let ((right (+ left outer-width))) |
| 8066 | (setq top (max top-margin (- top (- bottom bottom-margin))))) | 8116 | (cond |
| 8067 | ((< top top-margin) | 8117 | ((> right right-margin) |
| 8068 | ;; Move frame down. | 8118 | ;; Move frame to left. |
| 8069 | (setq top top-margin))))) | 8119 | (setq left (max left-margin (- left (- right right-margin))))) |
| 8070 | ;; Apply changes. | 8120 | ((< left left-margin) |
| 8071 | (set-frame-position frame left top) | 8121 | ;; Move frame to right. |
| 8072 | ;; Clumsily try to translate our calculations to what | 8122 | (setq left left-margin))))) |
| 8073 | ;; `set-frame-size' wants. | 8123 | ;; Fit height to constraints. |
| 8074 | (when width | 8124 | (when height |
| 8075 | (setq width (- (+ (frame-text-width) width) | 8125 | (unless frame-resize-pixelwise |
| 8076 | extra-width window-body-width))) | 8126 | (setq height (* (/ (+ height char-height -1) char-height) |
| 8077 | (when height | 8127 | char-height))) |
| 8078 | (setq height (- (+ (frame-text-height) height) | 8128 | ;; The new outer height. |
| 8079 | extra-height window-height))) | 8129 | (setq outer-height (+ height outer-minus-body-height)) |
| 8080 | (set-frame-size | 8130 | ;; Preserve margins. |
| 8081 | frame | 8131 | (let ((bottom (+ top outer-height))) |
| 8082 | (if width | 8132 | (cond |
| 8083 | (if frame-resize-pixelwise | 8133 | ((> bottom bottom-margin) |
| 8084 | width | 8134 | ;; Move frame up. |
| 8085 | (/ width char-width)) | 8135 | (setq top (max top-margin (- top (- bottom bottom-margin))))) |
| 8086 | (frame-text-width)) | 8136 | ((< top top-margin) |
| 8087 | (if height | 8137 | ;; Move frame down. |
| 8088 | (if frame-resize-pixelwise | 8138 | (setq top top-margin))))) |
| 8089 | height | 8139 | ;; Apply our changes. |
| 8090 | (/ height char-height)) | 8140 | (setq text-width |
| 8091 | (frame-text-height)) | 8141 | (if width |
| 8092 | frame-resize-pixelwise))))) | 8142 | (+ width text-minus-body-width) |
| 8143 | (frame-text-width frame))) | ||
| 8144 | (setq text-height | ||
| 8145 | (if height | ||
| 8146 | (+ height text-minus-body-height) | ||
| 8147 | (frame-text-height frame))) | ||
| 8148 | (modify-frame-parameters | ||
| 8149 | frame `((left . ,left) (top . ,top) | ||
| 8150 | (width . (text-pixels . ,text-width)) | ||
| 8151 | (height . (text-pixels . ,text-height))))))) | ||
| 8093 | 8152 | ||
| 8094 | (defun fit-window-to-buffer (&optional window max-height min-height max-width min-width preserve-size) | 8153 | (defun fit-window-to-buffer (&optional window max-height min-height max-width min-width preserve-size) |
| 8095 | "Adjust size of WINDOW to display its buffer's contents exactly. | 8154 | "Adjust size of WINDOW to display its buffer's contents exactly. |
| @@ -8286,6 +8345,168 @@ Return non-nil if the window was shrunk, nil otherwise." | |||
| 8286 | (when (and (window-combined-p window) | 8345 | (when (and (window-combined-p window) |
| 8287 | (pos-visible-in-window-p (point-min) window)) | 8346 | (pos-visible-in-window-p (point-min) window)) |
| 8288 | (fit-window-to-buffer window (window-total-height window)))) | 8347 | (fit-window-to-buffer window (window-total-height window)))) |
| 8348 | |||
| 8349 | (defun window-largest-empty-rectangle--maximums-1 (quad maximums) | ||
| 8350 | "Support function for `window-largest-empty-rectangle'." | ||
| 8351 | (cond | ||
| 8352 | ((null maximums) | ||
| 8353 | (list quad)) | ||
| 8354 | ((> (car quad) (caar maximums)) | ||
| 8355 | (cons quad maximums)) | ||
| 8356 | (t | ||
| 8357 | (cons (car maximums) | ||
| 8358 | (window-largest-empty-rectangle--maximums-1 quad (cdr maximums)))))) | ||
| 8359 | |||
| 8360 | (defun window-largest-empty-rectangle--maximums (quad maximums count) | ||
| 8361 | "Support function for `window-largest-empty-rectangle'." | ||
| 8362 | (setq maximums (window-largest-empty-rectangle--maximums-1 quad maximums)) | ||
| 8363 | (if (> (length maximums) count) | ||
| 8364 | (nbutlast maximums) | ||
| 8365 | maximums)) | ||
| 8366 | |||
| 8367 | (defun window-largest-empty-rectangle--disjoint-maximums (maximums count) | ||
| 8368 | "Support function for `window-largest-empty-rectangle'." | ||
| 8369 | (setq maximums (sort maximums (lambda (x y) (> (car x) (car y))))) | ||
| 8370 | (let ((new-length 0) | ||
| 8371 | new-maximums) | ||
| 8372 | (while (and maximums (< new-length count)) | ||
| 8373 | (let* ((maximum (car maximums)) | ||
| 8374 | (at (nth 2 maximum)) | ||
| 8375 | (to (nth 3 maximum))) | ||
| 8376 | (catch 'drop | ||
| 8377 | (dolist (new-maximum new-maximums) | ||
| 8378 | (let ((new-at (nth 2 new-maximum)) | ||
| 8379 | (new-to (nth 3 new-maximum))) | ||
| 8380 | (when (if (< at new-at) (> to new-at) (< at new-to)) | ||
| 8381 | ;; Intersection -> drop. | ||
| 8382 | (throw 'drop nil)))) | ||
| 8383 | (setq new-maximums (cons maximum new-maximums)) | ||
| 8384 | (setq new-length (1+ new-length))) | ||
| 8385 | (setq maximums (cdr maximums)))) | ||
| 8386 | |||
| 8387 | (nreverse new-maximums))) | ||
| 8388 | |||
| 8389 | (defun window-largest-empty-rectangle (&optional window count min-width min-height positions left) | ||
| 8390 | "Return dimensions of largest empty rectangle in WINDOW. | ||
| 8391 | WINDOW must be a live window and defaults to the selected one. | ||
| 8392 | |||
| 8393 | The return value is a triple of the width and the start and end | ||
| 8394 | Y-coordinates of the largest rectangle that can be inscribed into | ||
| 8395 | the empty space (the space not displaying any text) of WINDOW's | ||
| 8396 | text area. The return value is nil if the current glyph matrix | ||
| 8397 | of WINDOW is not up-to-date. | ||
| 8398 | |||
| 8399 | Optional argument COUNT, if non-nil, specifies the maximum number | ||
| 8400 | of rectangles to return. This means that the return value is a | ||
| 8401 | list of triples specifying rectangles with the largest rectangle | ||
| 8402 | first. COUNT can be also a cons cell whose car specifies the | ||
| 8403 | number of rectangles to return and whose cdr, if non-nil, states | ||
| 8404 | that all rectangles returned must be disjoint. | ||
| 8405 | |||
| 8406 | Note that the right edge of any rectangle returned by this | ||
| 8407 | function is the right edge of WINDOW (the left edge if its buffer | ||
| 8408 | displays RTL text). | ||
| 8409 | |||
| 8410 | Optional arguments MIN-WIDTH and MIN-HEIGHT, if non-nil, specify | ||
| 8411 | the minimum width and height of any rectangle returned. | ||
| 8412 | |||
| 8413 | Optional argument POSITIONS, if non-nil, is a cons cell whose car | ||
| 8414 | specifies the uppermost and whose cdr specifies the lowermost | ||
| 8415 | pixel position that must be covered by any rectangle returned. | ||
| 8416 | Note that positions are counted from the start of the text area | ||
| 8417 | of WINDOW. | ||
| 8418 | |||
| 8419 | Optional argument LEFT, if non-nil, means to return values suitable for | ||
| 8420 | buffers displaying right to left text." | ||
| 8421 | ;; Process lines as returned by ‘window-lines-pixel-dimensions’. | ||
| 8422 | ;; STACK is a stack that contains rows that have to be processed yet. | ||
| 8423 | (let* ((window (window-normalize-window window t)) | ||
| 8424 | (disjoint (and (consp count) (cdr count))) | ||
| 8425 | (count (or (and (numberp count) count) | ||
| 8426 | (and (consp count) (numberp (car count)) (car count)))) | ||
| 8427 | (rows (window-lines-pixel-dimensions window nil nil t t left)) | ||
| 8428 | (rows-at 0) | ||
| 8429 | (max-size 0) | ||
| 8430 | row stack stack-at stack-to | ||
| 8431 | top top-width top-at top-to top-size | ||
| 8432 | max-width max-at max-to maximums) | ||
| 8433 | ;; ROWS-AT is the position where the first element of ROWS starts. | ||
| 8434 | ;; STACK-AT is the position where the first element of STACK starts. | ||
| 8435 | (while rows | ||
| 8436 | (setq row (car rows)) | ||
| 8437 | (if (or (not stack) (>= (car row) (caar stack))) | ||
| 8438 | (progn | ||
| 8439 | (unless stack | ||
| 8440 | (setq stack-at rows-at)) | ||
| 8441 | (setq stack (cons row stack)) | ||
| 8442 | ;; Set ROWS-AT to where the first element of ROWS ends | ||
| 8443 | ;; which, after popping ROW, makes it the start position of | ||
| 8444 | ;; the next ROW. | ||
| 8445 | (setq rows-at (cdr row)) | ||
| 8446 | (setq rows (cdr rows))) | ||
| 8447 | (setq top (car stack)) | ||
| 8448 | (setq stack (cdr stack)) | ||
| 8449 | (setq top-width (car top)) | ||
| 8450 | (setq top-at (if stack (cdar stack) stack-at)) | ||
| 8451 | (setq top-to (cdr top)) | ||
| 8452 | (setq top-size (* top-width (- top-to top-at))) | ||
| 8453 | (unless (or (and min-width (< top-width min-width)) | ||
| 8454 | (and min-height (< (- top-to top-at) min-height)) | ||
| 8455 | (and positions | ||
| 8456 | (or (> top-at (car positions)) | ||
| 8457 | (< top-to (cdr positions))))) | ||
| 8458 | (if count | ||
| 8459 | (if disjoint | ||
| 8460 | (setq maximums (cons (list top-size top-width top-at top-to) | ||
| 8461 | maximums)) | ||
| 8462 | (setq maximums (window-largest-empty-rectangle--maximums | ||
| 8463 | (list top-size top-width top-at top-to) | ||
| 8464 | maximums count))) | ||
| 8465 | (when (> top-size max-size) | ||
| 8466 | (setq max-size top-size) | ||
| 8467 | (setq max-width top-width) | ||
| 8468 | (setq max-at top-at) | ||
| 8469 | (setq max-to top-to)))) | ||
| 8470 | (if (and stack (> (caar stack) (car row))) | ||
| 8471 | ;; Have new top element of stack include old top. | ||
| 8472 | (setq stack (cons (cons (caar stack) (cdr top)) (cdr stack))) | ||
| 8473 | ;; Move rows-at backwards to top-at. | ||
| 8474 | (setq rows-at top-at)))) | ||
| 8475 | |||
| 8476 | (when stack | ||
| 8477 | ;; STACK-TO is the position where the stack ends. | ||
| 8478 | (setq stack-to (cdar stack)) | ||
| 8479 | (while stack | ||
| 8480 | (setq top (car stack)) | ||
| 8481 | (setq stack (cdr stack)) | ||
| 8482 | (setq top-width (car top)) | ||
| 8483 | (setq top-at (if stack (cdar stack) stack-at)) | ||
| 8484 | (setq top-size (* top-width (- stack-to top-at))) | ||
| 8485 | (unless (or (and min-width (< top-width min-width)) | ||
| 8486 | (and min-height (< (- stack-to top-at) min-height)) | ||
| 8487 | (and positions | ||
| 8488 | (or (> top-at (car positions)) | ||
| 8489 | (< stack-to (cdr positions))))) | ||
| 8490 | (if count | ||
| 8491 | (if disjoint | ||
| 8492 | (setq maximums (cons (list top-size top-width top-at stack-to) | ||
| 8493 | maximums)) | ||
| 8494 | (setq maximums (window-largest-empty-rectangle--maximums | ||
| 8495 | (list top-size top-width top-at stack-to) | ||
| 8496 | maximums count))) | ||
| 8497 | (when (> top-size max-size) | ||
| 8498 | (setq max-size top-size) | ||
| 8499 | (setq max-width top-width) | ||
| 8500 | (setq max-at top-at) | ||
| 8501 | (setq max-to stack-to)))))) | ||
| 8502 | |||
| 8503 | (cond | ||
| 8504 | (maximums | ||
| 8505 | (if disjoint | ||
| 8506 | (window-largest-empty-rectangle--disjoint-maximums maximums count) | ||
| 8507 | maximums)) | ||
| 8508 | ((> max-size 0) | ||
| 8509 | (list max-width max-at max-to))))) | ||
| 8289 | 8510 | ||
| 8290 | (defun kill-buffer-and-window () | 8511 | (defun kill-buffer-and-window () |
| 8291 | "Kill the current buffer and delete the selected window." | 8512 | "Kill the current buffer and delete the selected window." |