commit ff89d27c07de4ac2efc695b06e8aa1faec5d65d1 (HEAD, refs/remotes/origin/master) Merge: a96f6de544 530c3491e8 Author: Stefan Kangas Date: Fri Mar 18 07:01:18 2022 +0100 Merge from origin/emacs-28 530c3491e8 Improve documentation of bookmark default sorting 11492259b1 ; * doc/lispref/display.texi (Overlay Arrow): More accurat... commit a96f6de5447f296dbadc90de9a1157062e9ba491 Author: Po Lu Date: Fri Mar 18 05:48:10 2022 +0000 Allow dragging messages with file names on Haiku * src/haiku_select.cc (be_add_refs_data): New function. * src/haikuselect.c (haiku_lisp_to_message): Handle `ref' type correctly. * src/haikuselect.h: Update prototypes. diff --git a/src/haiku_select.cc b/src/haiku_select.cc index 4212f60a48..9012639d6a 100644 --- a/src/haiku_select.cc +++ b/src/haiku_select.cc @@ -337,3 +337,20 @@ be_add_message_data (void *message, const char *name, return msg->AddData (name, type_code, buf, buf_size) != B_OK; } + +int +be_add_refs_data (void *message, const char *name, + const char *filename) +{ + BEntry entry (filename); + entry_ref ref; + BMessage *msg = (BMessage *) message; + + if (entry.InitCheck () != B_OK) + return 1; + + if (entry.GetRef (&ref) != B_OK) + return 1; + + return msg->AddRef (name, &ref) != B_OK; +} diff --git a/src/haikuselect.c b/src/haikuselect.c index 7474ff1232..807cbc2493 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -378,7 +378,10 @@ haiku_lisp_to_message (Lisp_Object obj, void *message) switch (type_code) { case 'RREF': - signal_error ("Cannot deserialize data type", type_sym); + CHECK_STRING (data); + + if (be_add_refs_data (message, SSDATA (name), SSDATA (data))) + signal_error ("Invalid file name", data); break; case 'SHRT': diff --git a/src/haikuselect.h b/src/haikuselect.h index 366890d1a4..4869d9d33c 100644 --- a/src/haikuselect.h +++ b/src/haikuselect.h @@ -91,6 +91,8 @@ extern "C" extern int be_add_message_data (void *message, const char *name, int32 type_code, const void *buf, ssize_t buf_size); + extern int be_add_refs_data (void *message, const char *name, + const char *filename); #ifdef __cplusplus }; #endif commit 45609c347e7810b20c54bedc1ce5355182f240e5 Author: Po Lu Date: Fri Mar 18 13:17:19 2022 +0800 Allow dragging files from Dired to other programs * etc/NEWS: Announce new user option `dired-mouse-drag-files'. * lisp/dired.el (dired-mouse-drag-files): New user option. (dired-mouse-drag): New command. (dired-mouse-drag-files-map): New variable. (dired-insert-set-properties): Add additional keymap if mouse dragging is enabled. * lisp/select.el (xselect-convert-to-targets): Handle new form of selection converters. (xselect-convert-to-username): (xselect-convert-to-text-uri-list): (xselect-uri-list-available-p): New functions. (selection-converter-alist): Add them as selection converters. * src/xselect.c (x_get_local_selection): Handle new form of selection converters. (syms_of_xselect): Update doc strings. diff --git a/etc/NEWS b/etc/NEWS index f4d8756950..e2546bb3ca 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -932,6 +932,11 @@ the thumbnail file. ** Dired +*** New user option 'dired-mouse-drag-files'. +If non-nil, dragging filenames with the mouse in a Dired buffer will +initiate a drag-and-drop session allowing them to be opened in other +programs. + *** New user option 'dired-free-space'. Dired will now, by default, include the free space in the first line instead of having it on a separate line. To get the previous behavior diff --git a/lisp/dired.el b/lisp/dired.el index bca3018923..da3c3c80cc 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -248,6 +248,18 @@ The target is used in the prompt for file copy, rename etc." (other :tag "Try to guess" t)) :group 'dired) +(defcustom dired-mouse-drag-files nil + "If non-nil, allow the mouse to drag files from inside a Dired buffer. +Dragging the mouse and then releasing it over the window of +another program will result in that program opening the file, or +creating a copy of it . + +If the value is `link', then a symbolic link will be created to +the file instead by the other program (usually a file manager)." + :type '(choice (const :tag "Don't allow dragging" nil) + (const :tag "Copy file to other window" tx) + (const :tag "Create symbolic link to file" link))) + (defcustom dired-copy-preserve-time t "If non-nil, Dired preserves the last-modified time in a file copy. \(This works on only some systems.)" @@ -1674,6 +1686,36 @@ see `dired-use-ls-dired' for more details.") beg)) beg)))) +(declare-function x-begin-drag "xfns.cx") + +(defun dired-mouse-drag (event) + "Begin a drag-and-drop operation for the file at EVENT. +If we get a mouse motion event right " + (interactive "e") + (save-excursion + (goto-char (posn-point (event-end event))) + (track-mouse + (let ((new-event (read-event))) + (if (not (eq (event-basic-type new-event) 'mouse-movement)) + (push new-event unread-command-events) + ;; We can get an error if there's by some chance no file + ;; name at point. + (condition-case nil + (progn + (gui-backend-set-selection 'XdndSelection + (dired-file-name-at-point)) + (x-begin-drag '("text/uri-list" + "text/x-dnd-username") + (if (eq 'dired-mouse-drag-files 'link) + 'XdndActionLink + 'XdndActionCopy))) + (error (push new-event unread-command-events)))))))) + +(defvar dired-mouse-drag-files-map (let ((keymap (make-sparse-keymap))) + (define-key keymap [down-mouse-1] #'dired-mouse-drag) + keymap) + "Keymap applied to file names when `dired-mouse-drag-files' is enabled.") + (defun dired-insert-set-properties (beg end) "Add various text properties to the lines in the region, from BEG to END." (save-excursion @@ -1693,10 +1735,15 @@ see `dired-use-ls-dired' for more details.") (progn (dired-move-to-end-of-filename) (point)) - '(mouse-face - highlight - dired-filename t - help-echo "mouse-2: visit this file in other window")) + (append `(mouse-face + highlight + dired-filename t + help-echo ,(if dired-mouse-drag-files + "down-mouse-1: drag this file to another program +mouse-2: visit this file in other window" + "mouse-2: visit this file in other window")) + (when dired-mouse-drag-files + `(keymap ,dired-mouse-drag-files-map)))) (when (< (+ (point) 4) (line-end-position)) (put-text-property (+ (point) 4) (line-end-position) 'invisible 'dired-hide-details-link)))) diff --git a/lisp/select.el b/lisp/select.el index e9bc545117..36452776e9 100644 --- a/lisp/select.el +++ b/lisp/select.el @@ -546,16 +546,22 @@ two markers or an overlay. Otherwise, it is nil." (if len (xselect--int-to-cons len)))) -(defun xselect-convert-to-targets (_selection _type _value) +(defun xselect-convert-to-targets (selection _type value) ;; return a vector of atoms, but remove duplicates first. (let* ((all (cons 'TIMESTAMP (cons 'MULTIPLE - (mapcar 'car selection-converter-alist)))) + (mapcar (lambda (conv) + (if (or (not (consp (cdr conv))) + (funcall (cadr conv) selection + (car conv) value)) + (car conv) + '_EMACS_INTERNAL)) + selection-converter-alist)))) (rest all)) (while rest (cond ((memq (car rest) (cdr rest)) (setcdr rest (delq (car rest) (cdr rest)))) - ((eq (car (cdr rest)) '_EMACS_INTERNAL) ; shh, it's a secret + ((eq (car (cdr rest)) '_EMACS_INTERNAL) (setcdr rest (cdr (cdr rest)))) (t (setq rest (cdr rest))))) @@ -632,6 +638,30 @@ This function returns the string \"emacs\"." (when (eq selection 'CLIPBOARD) 'NULL)) +(defun xselect-convert-to-username (_selection _type _value) + (user-real-login-name)) + +(defun xselect-convert-to-text-uri-list (_selection _type value) + (when (and (stringp value) + (file-exists-p value)) + (concat (url-encode-url + ;; Uncomment the following code code in a better world where + ;; people write correct code that adds the hostname to the URI. + ;; Since most programs don't implement this properly, we omit the + ;; hostname so that copying files actually works. Most properly + ;; written programs will look at WM_CLIENT_MACHINE to determine + ;; the hostname anyway. (format "file://%s%s\n" (system-name) + ;; (expand-file-name value)) + (concat "file://" (expand-file-name value))) + "\n"))) + +(defun xselect-uri-list-available-p (selection _type value) + "Return whether or not `text/uri-list' is a valid target for SELECTION. +VALUE is the local selection value of SELECTION." + (and (eq selection 'XdndSelection) + (stringp value) + (file-exists-p value))) + (setq selection-converter-alist '((TEXT . xselect-convert-to-string) (COMPOUND_TEXT . xselect-convert-to-string) @@ -639,6 +669,8 @@ This function returns the string \"emacs\"." (UTF8_STRING . xselect-convert-to-string) (text/plain . xselect-convert-to-string) (text/plain\;charset=utf-8 . xselect-convert-to-string) + (text/uri-list . (xselect-uri-list-available-p . xselect-convert-to-text-uri-list)) + (text/x-xdnd-username . xselect-convert-to-username) (TARGETS . xselect-convert-to-targets) (LENGTH . xselect-convert-to-length) (DELETE . xselect-convert-to-delete) diff --git a/src/xselect.c b/src/xselect.c index cdc70d3e24..76a2f9f507 100644 --- a/src/xselect.c +++ b/src/xselect.c @@ -386,6 +386,9 @@ x_get_local_selection (Lisp_Object selection_symbol, Lisp_Object target_type, CHECK_SYMBOL (target_type); handler_fn = Fcdr (Fassq (target_type, Vselection_converter_alist)); + if (CONSP (handler_fn)) + handler_fn = XCDR (handler_fn); + if (!NILP (handler_fn)) value = call3 (handler_fn, selection_symbol, (local_request ? Qnil : target_type), @@ -2690,11 +2693,18 @@ syms_of_xselect (void) DEFVAR_LISP ("selection-converter-alist", Vselection_converter_alist, doc: /* An alist associating X Windows selection-types with functions. These functions are called to convert the selection, with three args: -the name of the selection (typically `PRIMARY', `SECONDARY', or `CLIPBOARD'); -a desired type to which the selection should be converted; -and the local selection value (whatever was given to +the name of the selection (typically `PRIMARY', `SECONDARY', or +`CLIPBOARD'); a desired type to which the selection should be +converted; and the local selection value (whatever was given to `x-own-selection-internal'). +On X Windows, the function can also be a cons of (PREDICATE +. FUNCTION), where PREDICATE determines whether or not the selection +type will appear in the list of selection types available to other +programs, and FUNCTION is the function which is actually called. +PREDICATE is called with the same arguments as FUNCTION, and should +return a non-nil value if the data type is to appear in that list. + The function should return the value to send to the X server \(typically a string). A return value of nil means that the conversion could not be done. commit 530c3491e89bd316e628f67d5cebb7db6e7d470a (refs/remotes/origin/emacs-28) Author: Karl Fogel Date: Thu Mar 17 21:18:26 2022 -0500 Improve documentation of bookmark default sorting * lisp/bookmark.el (bookmark-alist, bookmark-store, bookmark-maybe-sort-alist): Update doc strings and comments. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index d568f643d9..cc9956c80a 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -249,11 +249,13 @@ functions have a binding in this keymap.") Bookmark functions update the value automatically. You probably do NOT want to change the value yourself. -The value is an alist with bookmarks of the form +The value is an alist whose elements are of the form (BOOKMARK-NAME . PARAM-ALIST) -or the deprecated form (BOOKMARK-NAME PARAM-ALIST). +or the deprecated form (BOOKMARK-NAME PARAM-ALIST). The alist is +ordered from most recently created bookmark at the front to least +recently created bookmark at the end. BOOKMARK-NAME is the name you gave to the bookmark when creating it. @@ -577,10 +579,10 @@ old one." ;; Modify using the new (NAME . ALIST) format. (setcdr bm alist)) - ;; otherwise just cons it onto the front (either the bookmark - ;; doesn't exist already, or there is no prefix arg. In either - ;; case, we want the new bookmark consed onto the alist...) - + ;; Otherwise just put it onto the front of the list. Either the + ;; bookmark doesn't exist already, or there is no prefix arg. + ;; In either case, we want the new bookmark on the front of the + ;; list, since the list is kept in reverse order of creation. (push (cons stripped-name alist) bookmark-alist)) ;; Added by db @@ -1138,7 +1140,9 @@ it to the name of the bookmark currently being set, advancing (defun bookmark-maybe-sort-alist () "Return `bookmark-alist' for display. -If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist." +If `bookmark-sort-flag' is non-nil, then return a sorted copy of the alist. +Otherwise, just return `bookmark-alist', which by default is ordered +from most recently created to least recently created bookmark." (if bookmark-sort-flag (sort (copy-alist bookmark-alist) (lambda (x y) (string-lessp (car x) (car y)))) commit e781cbb2d3ec3b4cfd35cd29ccba8e1c265fad4a Author: Po Lu Date: Fri Mar 18 08:22:50 2022 +0800 Minor fixes to DND support * src/xterm.c (x_dnd_begin_drag_and_drop): Free targets afterwards. (handle_one_xevent): Only calculate dnd_grab if DND is in progress. diff --git a/src/xterm.c b/src/xterm.c index 6485374e2a..eb2ecf7d65 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1157,6 +1157,7 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, x_dnd_in_progress = false; x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); } FRAME_DISPLAY_INFO (f)->grabbed = 0; @@ -1167,6 +1168,8 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, } } + x_set_dnd_targets (NULL, 0); + #ifdef USE_GTK current_hold_quit = NULL; #endif @@ -12077,30 +12080,31 @@ handle_one_xevent (struct x_display_info *dpyinfo, bool tool_bar_p = false; bool dnd_grab = false; - for (int i = 1; i < 8; ++i) - { - if (i != event->xbutton.button - && event->xbutton.state & (Button1Mask << (i - 1))) - dnd_grab = true; - } - if (x_dnd_in_progress - && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame) - && !dnd_grab - && event->xbutton.type == ButtonRelease) + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { - x_dnd_in_progress = false; + for (int i = 1; i < 8; ++i) + { + if (i != event->xbutton.button + && event->xbutton.state & (Button1Mask << (i - 1))) + dnd_grab = true; + } - if (x_dnd_last_seen_window != None - && x_dnd_last_protocol_version != -1) - x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, - x_dnd_selection_timestamp, - x_dnd_last_protocol_version); + if (dnd_grab && event->xbutton.type == ButtonRelease) + { + x_dnd_in_progress = false; + + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); - x_dnd_last_protocol_version = -1; - x_dnd_last_seen_window = None; - x_dnd_frame = NULL; - x_set_dnd_targets (NULL, 0); + x_dnd_last_protocol_version = -1; + x_dnd_last_seen_window = None; + x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); + } goto OTHER; } @@ -13053,31 +13057,33 @@ handle_one_xevent (struct x_display_info *dpyinfo, XButtonEvent bv; bool dnd_grab = false; - for (int i = 0; i < xev->buttons.mask_len * 8; ++i) - { - if (i != xev->detail && XIMaskIsSet (xev->buttons.mask, i)) - dnd_grab = true; - } - if (x_dnd_in_progress - && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame) - && !dnd_grab - && xev->evtype == XI_ButtonRelease) + && dpyinfo == FRAME_DISPLAY_INFO (x_dnd_frame)) { - x_dnd_in_progress = false; + for (int i = 0; i < xev->buttons.mask_len * 8; ++i) + { + if (i != xev->detail && XIMaskIsSet (xev->buttons.mask, i)) + dnd_grab = true; + } - if (x_dnd_last_seen_window != None - && x_dnd_last_protocol_version != -1) - x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, - x_dnd_selection_timestamp, - x_dnd_last_protocol_version); + if (!dnd_grab + && xev->evtype == XI_ButtonRelease) + { + x_dnd_in_progress = false; - x_dnd_last_protocol_version = -1; - x_dnd_last_seen_window = None; - x_dnd_frame = NULL; - x_set_dnd_targets (NULL, 0); + if (x_dnd_last_seen_window != None + && x_dnd_last_protocol_version != -1) + x_dnd_send_drop (x_dnd_frame, x_dnd_last_seen_window, + x_dnd_selection_timestamp, + x_dnd_last_protocol_version); - goto XI_OTHER; + x_dnd_last_protocol_version = -1; + x_dnd_last_seen_window = None; + x_dnd_frame = NULL; + x_set_dnd_targets (NULL, 0); + + goto XI_OTHER; + } } if (x_dnd_in_progress) commit 06ea82e4e3b9c419a632082ddbce7ec5fe933c9c Author: Stefan Monnier Date: Thu Mar 17 19:07:59 2022 -0400 Remove some early-bootstrap dependencies for `advice` The dependencies between `advice`, cl-generic`, `bytecomp`, `cl-lib`, `simple`, `help`, ... were becoming unmanageable. Break the reliance on `advice` (which includes making sure the compiler is not needed during the early bootstrap). * lisp/simple.el (pre-redisplay-function): Set without using `add-function`. * lisp/loadup.el (advice, simple): Move to after `cl-generic`. * lisp/help.el (command-error-function): Set without using `add-function`. (help-command-error-confusable-suggestions): Explicitly call `command-error-default-function` instead. * lisp/emacs-lisp/cl-macs.el (pcase--mutually-exclusive-p): Don't optimize during early-bootstrap. * lisp/emacs-lisp/cl-generic.el (cl--generic-lambda): Tiny simplification. (cl-defmethod): Label the obsolescence warning as it should. (cl--generic-compiler): New variable. (cl--generic-get-dispatcher): Use it. (cl--generic-prefill-dispatchers): Make freshly made dispatchers. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 7b11c0c815..295512d51e 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -392,9 +392,9 @@ the specializer used will be the one returned by BODY." . ,(lambda () spec-args)) macroexpand-all-environment))) (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - (when (assq 'interactive (cadr fun)) + (when (assq 'interactive body) (message "Interactive forms not supported in generic functions: %S" - (assq 'interactive (cadr fun)))) + (assq 'interactive body))) ;; First macroexpand away the cl-function stuff (e.g. &key and ;; destructuring args, `declare' and whatnot). (pcase (macroexpand fun macroenv) @@ -526,7 +526,7 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (let* ((obsolete (get name 'byte-obsolete-info))) (macroexp-warn-and-return (macroexp--obsolete-warning name obsolete "generic function") - nil nil nil orig-name))) + nil (list 'obsolete name) nil orig-name))) ;; You could argue that `defmethod' modifies rather than defines the ;; function, so warnings like "not known to be defined" are fair game. ;; But in practice, it's common to use `cl-defmethod' @@ -614,6 +614,14 @@ The set of acceptable TYPEs (also called \"specializers\") is defined (defvar cl--generic-dispatchers (make-hash-table :test #'equal)) +(defvar cl--generic-compiler + ;; Don't byte-compile the dispatchers if cl-generic itself is not + ;; compiled. Otherwise the byte-compiler and all the code on + ;; which it depends needs to be usable before cl-generic is loaded, + ;; which imposes a significant burden on the bootstrap. + (if (consp (lambda (x) (+ x 1))) + (lambda (exp) (eval exp t)) #'byte-compile)) + (defun cl--generic-get-dispatcher (dispatch) (with-memoization ;; We need `copy-sequence` here because this `dispatch' object might be @@ -658,7 +666,8 @@ The set of acceptable TYPEs (also called \"specializers\") is defined ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. - (byte-compile + (funcall + cl--generic-compiler `(lambda (generic dispatches-left methods) ;; FIXME: We should find a way to expand `with-memoize' once ;; and forall so we don't need `subr-x' when we get here. @@ -886,11 +895,20 @@ those methods.") (setq arg-or-context `(&context . ,arg-or-context))) (unless (fboundp 'cl--generic-get-dispatcher) (require 'cl-generic)) - (let ((fun (cl--generic-get-dispatcher - `(,arg-or-context - ,@(apply #'append - (mapcar #'cl-generic-generalizers specializers)) - ,cl--generic-t-generalizer)))) + (let ((fun + ;; Let-bind cl--generic-dispatchers so we *re*compute the function + ;; from scratch, since the one in the cache may be non-compiled! + (let ((cl--generic-dispatchers (make-hash-table)) + ;; When compiling `cl-generic' during bootstrap, make sure + ;; we prefill with compiled dispatchers even though the loaded + ;; `cl-generic' is still interpreted. + (cl--generic-compiler + (if (featurep 'bytecomp) #'byte-compile cl--generic-compiler))) + (cl--generic-get-dispatcher + `(,arg-or-context + ,@(apply #'append + (mapcar #'cl-generic-generalizers specializers)) + ,cl--generic-t-generalizer))))) ;; Recompute dispatch at run-time, since the generalizers may be slightly ;; different (e.g. byte-compiled rather than interpreted). ;; FIXME: There is a risk that the run-time generalizer is not equivalent diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 0d0b5b5158..5d2a7c03ac 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -3279,8 +3279,9 @@ the form NAME which is a shorthand for (NAME NAME)." (funcall orig pred1 (cl--defstruct-predicate t2)))) (funcall orig pred1 pred2)))) -(advice-add 'pcase--mutually-exclusive-p - :around #'cl--pcase-mutually-exclusive-p) +(when (fboundp 'advice-add) ;Not available during bootstrap. + (advice-add 'pcase--mutually-exclusive-p + :around #'cl--pcase-mutually-exclusive-p)) (defun cl-struct-sequence-type (struct-type) diff --git a/lisp/help.el b/lisp/help.el index f1a617f850..780f5daac7 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -621,7 +621,7 @@ If INSERT (the prefix arg) is non-nil, insert the message in the buffer." (enable-recursive-minibuffers t) val) (setq val (completing-read (format-prompt "Where is command" fn) - obarray 'commandp t nil nil + obarray #'commandp t nil nil (and fn (symbol-name fn)))) (list (unless (equal val "") (intern val)) current-prefix-arg))) @@ -2147,7 +2147,10 @@ the suggested string to use instead. See confusables ", ") string)))) -(defun help-command-error-confusable-suggestions (data _context _signal) +(defun help-command-error-confusable-suggestions (data context signal) + ;; Delegate most of the work to the original default value of + ;; `command-error-function' implemented in C. + (command-error-default-function data context signal) (pcase data (`(void-variable ,var) (let ((suggestions (help-uni-confusable-suggestions @@ -2156,8 +2159,12 @@ the suggested string to use instead. See (princ (concat "\n " suggestions) t)))) (_ nil))) -(add-function :after command-error-function - #'help-command-error-confusable-suggestions) +(when (eq command-error-function #'command-error-default-function) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq command-error-function + #'help-command-error-confusable-suggestions)) (define-obsolete-function-alias 'help-for-help-internal #'help-for-help "28.1") diff --git a/lisp/loadup.el b/lisp/loadup.el index 81172c584d..faeb9188e4 100644 --- a/lisp/loadup.el +++ b/lisp/loadup.el @@ -196,11 +196,9 @@ (setq definition-prefixes new)) (load "button") ;After loaddefs, because of define-minor-mode! -(load "emacs-lisp/nadvice") (load "emacs-lisp/cl-preloaded") (load "obarray") ;abbrev.el is implemented in terms of obarrays. (load "abbrev") ;lisp-mode.el and simple.el use define-abbrev-table. -(load "simple") (load "help") @@ -251,6 +249,8 @@ (let ((max-specpdl-size (max max-specpdl-size 1800))) ;; A particularly demanding file to load; 1600 does not seem to be enough. (load "emacs-lisp/cl-generic")) +(load "simple") +(load "emacs-lisp/nadvice") (load "minibuffer") ;Needs cl-generic (and define-minor-mode). (load "frame") (load "startup") diff --git a/lisp/simple.el b/lisp/simple.el index accc119e2b..83f27e0dbb 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -6545,9 +6545,11 @@ is set to the buffer displayed in that window.") (with-current-buffer (window-buffer win) (run-hook-with-args 'pre-redisplay-functions win)))))) -(add-function :before pre-redisplay-function - #'redisplay--pre-redisplay-functions) - +(when (eq pre-redisplay-function #'ignore) + ;; Override the default set in the C code. + ;; This is not done using `add-function' so as to loosen the bootstrap + ;; dependencies. + (setq pre-redisplay-function #'redisplay--pre-redisplay-functions)) (defvar-local mark-ring nil "The list of former marks of the current buffer, most recent first.") commit 751c8f88c4faddb2b4f5d5ba3f051e8cd2c0153c Author: Mattias Engdegård Date: Mon Mar 14 12:57:29 2022 +0100 Put bytecode stack frame metadata in a struct Using a plain C struct instead of type-punning Lisp_Object stack slots makes the bytecode interpreter code more type-safe and potentially faster (from better alias analysis), and the special-purpose accessors are no longer needed. It also reduces the stack requirements when using 64-bit Lisp_Object on 32-bit platforms. * src/bytecode.c (enum stack_frame_index) (sf_get_ptr, sf_set_ptr, sf_get_lisp_ptr, sf_set_lisp_ptr, sf_get_saved_pc, sf_set_saved_pc): Remove. (BC_STACK_SIZE): Now in bytes, not Lisp words. (struct bc_frame): New. (init_bc_thread, mark_bytecode, Finternal_stack_stats, valid_sp) (exec_byte_code): * src/lisp.h (struct handler, get_act_rec, set_act_rec): Adapt to new struct bc_frame. diff --git a/src/bytecode.c b/src/bytecode.c index 65c3ad4da7..ed1f6ca4a8 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -335,20 +335,7 @@ bcall0 (Lisp_Object f) Ffuncall (1, &f); } -/* Layout of the stack frame header. */ -enum stack_frame_index { - SFI_SAVED_FP, /* previous frame pointer */ - - /* In a frame called directly from C, the following two members are NULL. */ - SFI_SAVED_TOP, /* previous stack pointer */ - SFI_SAVED_PC, /* previous program counter */ - - SFI_FUN, /* current function object */ - - SF_SIZE /* number of words in the header */ -}; - -/* The bytecode stack size in Lisp words. +/* The bytecode stack size in bytes. This is a fairly generous amount, but: - if users need more, we could allocate more, or just reserve the address space and allocate on demand @@ -357,7 +344,7 @@ enum stack_frame_index { - for maximum flexibility but a small runtime penalty, we could allocate the stack in smaller chunks as needed */ -#define BC_STACK_SIZE (512 * 1024) +#define BC_STACK_SIZE (512 * 1024 * sizeof (Lisp_Object)) /* Bytecode interpreter stack: @@ -385,51 +372,28 @@ enum stack_frame_index { : : */ -INLINE void * -sf_get_ptr (Lisp_Object *fp, enum stack_frame_index index) -{ - return XLP (fp[index]); -} - -INLINE void -sf_set_ptr (Lisp_Object *fp, enum stack_frame_index index, void *value) -{ - fp[index] = XIL ((uintptr_t)value); -} - -INLINE Lisp_Object * -sf_get_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index) -{ - return sf_get_ptr (fp, index); -} +/* bytecode stack frame header (footer, actually) */ +struct bc_frame { + struct bc_frame *saved_fp; /* previous frame pointer, + NULL if bottommost frame */ -INLINE void -sf_set_lisp_ptr (Lisp_Object *fp, enum stack_frame_index index, - Lisp_Object *value) -{ - sf_set_ptr (fp, index, value); -} + /* In a frame called directly from C, the following two members are NULL. */ + Lisp_Object *saved_top; /* previous stack pointer */ + const unsigned char *saved_pc; /* previous program counter */ -INLINE const unsigned char * -sf_get_saved_pc (Lisp_Object *fp) -{ - return sf_get_ptr (fp, SFI_SAVED_PC); -} + Lisp_Object fun; /* current function object */ -INLINE void -sf_set_saved_pc (Lisp_Object *fp, const unsigned char *value) -{ - sf_set_ptr (fp, SFI_SAVED_PC, (unsigned char *)value); -} + Lisp_Object next_stack[]; /* data stack of next frame */ +}; void init_bc_thread (struct bc_thread_state *bc) { - bc->stack = xmalloc (BC_STACK_SIZE * sizeof *bc->stack); + bc->stack = xmalloc (BC_STACK_SIZE); bc->stack_end = bc->stack + BC_STACK_SIZE; /* Put a dummy header at the bottom to indicate the first free location. */ - bc->fp = bc->stack; - memset (bc->fp, 0, SF_SIZE * sizeof *bc->stack); + bc->fp = (struct bc_frame *)bc->stack; + memset (bc->fp, 0, sizeof *bc->fp); } void @@ -441,16 +405,16 @@ free_bc_thread (struct bc_thread_state *bc) void mark_bytecode (struct bc_thread_state *bc) { - Lisp_Object *fp = bc->fp; + struct bc_frame *fp = bc->fp; Lisp_Object *top = NULL; /* stack pointer of topmost frame not known */ for (;;) { - Lisp_Object *next_fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP); + struct bc_frame *next_fp = fp->saved_fp; /* Only the dummy frame at the bottom has saved_fp = NULL. */ if (!next_fp) break; - mark_object (fp[SFI_FUN]); - Lisp_Object *frame_base = next_fp + SF_SIZE; + mark_object (fp->fun); + Lisp_Object *frame_base = next_fp->next_stack; if (top) { /* The stack pointer of a frame is known: mark the part of the stack @@ -464,7 +428,7 @@ mark_bytecode (struct bc_thread_state *bc) /* The stack pointer is unknown -- mark everything conservatively. */ mark_memory (frame_base, fp); } - top = sf_get_lisp_ptr (fp, SFI_SAVED_TOP); + top = fp->saved_top; fp = next_fp; } } @@ -477,10 +441,10 @@ DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats, struct bc_thread_state *bc = ¤t_thread->bc; int nframes = 0; int nruns = 0; - for (Lisp_Object *fp = bc->fp; fp; fp = sf_get_lisp_ptr (fp, SFI_SAVED_FP)) + for (struct bc_frame *fp = bc->fp; fp; fp = fp->saved_fp) { nframes++; - if (sf_get_lisp_ptr (fp, SFI_SAVED_TOP) == NULL) + if (fp->saved_top == NULL) nruns++; } fprintf (stderr, "%d stack frames, %d runs\n", nframes, nruns); @@ -491,8 +455,8 @@ DEFUN ("internal-stack-stats", Finternal_stack_stats, Sinternal_stack_stats, INLINE bool valid_sp (struct bc_thread_state *bc, Lisp_Object *sp) { - Lisp_Object *fp = bc->fp; - return sp < fp && sp + 1 >= sf_get_lisp_ptr (fp, SFI_SAVED_FP) + SF_SIZE; + struct bc_frame *fp = bc->fp; + return sp < (Lisp_Object *)fp && sp + 1 >= fp->saved_fp->next_stack; } /* Execute the byte-code in FUN. ARGS_TEMPLATE is the function arity @@ -532,20 +496,20 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, Lisp_Object *vectorp = XVECTOR (vector)->contents; EMACS_INT max_stack = XFIXNAT (maxdepth); - Lisp_Object *frame_base = bc->fp + SF_SIZE; - Lisp_Object *fp = frame_base + max_stack; + Lisp_Object *frame_base = bc->fp->next_stack; + struct bc_frame *fp = (struct bc_frame *)(frame_base + max_stack); - if (fp + SF_SIZE > bc->stack_end) + if ((char *)fp->next_stack > bc->stack_end) error ("Bytecode stack overflow"); /* Save the function object so that the bytecode and vector are held from removal by the GC. */ - fp[SFI_FUN] = fun; + fp->fun = fun; /* Save previous stack pointer and pc in the new frame. If we came directly from outside, these will be NULL. */ - sf_set_lisp_ptr (fp, SFI_SAVED_TOP, top); - sf_set_saved_pc (fp, pc); - sf_set_lisp_ptr (fp, SFI_SAVED_FP, bc->fp); + fp->saved_top = top; + fp->saved_pc = pc; + fp->saved_fp = bc->fp; bc->fp = fp; top = frame_base - 1; @@ -914,7 +878,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, CASE (Breturn): { - Lisp_Object *saved_top = sf_get_lisp_ptr (bc->fp, SFI_SAVED_TOP); + Lisp_Object *saved_top = bc->fp->saved_top; if (saved_top) { Lisp_Object val = TOP; @@ -925,11 +889,11 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, specpdl_ptr--; top = saved_top; - pc = sf_get_saved_pc (bc->fp); - Lisp_Object *fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP); + pc = bc->fp->saved_pc; + struct bc_frame *fp = bc->fp->saved_fp; bc->fp = fp; - Lisp_Object fun = fp[SFI_FUN]; + Lisp_Object fun = fp->fun; Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); bytestr_data = SDATA (bytestr); @@ -1004,9 +968,9 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, handlerlist = c->next; top = c->bytecode_top; op = c->bytecode_dest; - Lisp_Object *fp = bc->fp; + struct bc_frame *fp = bc->fp; - Lisp_Object fun = fp[SFI_FUN]; + Lisp_Object fun = fp->fun; Lisp_Object bytestr = AREF (fun, COMPILED_BYTECODE); Lisp_Object vector = AREF (fun, COMPILED_CONSTANTS); bytestr_data = SDATA (bytestr); @@ -1756,7 +1720,7 @@ exec_byte_code (Lisp_Object fun, ptrdiff_t args_template, exit: - bc->fp = sf_get_lisp_ptr (bc->fp, SFI_SAVED_FP); + bc->fp = bc->fp->saved_fp; Lisp_Object result = TOP; return result; diff --git a/src/lisp.h b/src/lisp.h index c90f901ebc..21709b1259 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -3546,7 +3546,7 @@ struct handler sys_jmp_buf jmp; EMACS_INT f_lisp_eval_depth; specpdl_ref pdlcount; - Lisp_Object *act_rec; + struct bc_frame *act_rec; int poll_suppress_count; int interrupt_input_blocked; }; @@ -4861,14 +4861,14 @@ extern void init_bc_thread (struct bc_thread_state *bc); extern void free_bc_thread (struct bc_thread_state *bc); extern void mark_bytecode (struct bc_thread_state *bc); -INLINE Lisp_Object * +INLINE struct bc_frame * get_act_rec (struct thread_state *th) { return th->bc.fp; } INLINE void -set_act_rec (struct thread_state *th, Lisp_Object *act_rec) +set_act_rec (struct thread_state *th, struct bc_frame *act_rec) { th->bc.fp = act_rec; } diff --git a/src/thread.h b/src/thread.h index a29af702d1..ddba1a2d99 100644 --- a/src/thread.h +++ b/src/thread.h @@ -35,9 +35,11 @@ along with GNU Emacs. If not, see . */ /* Byte-code interpreter thread state. */ struct bc_thread_state { - Lisp_Object *fp; /* current frame pointer (see bytecode.c) */ - Lisp_Object *stack; - Lisp_Object *stack_end; + struct bc_frame *fp; /* current frame pointer */ + + /* start and end of allocated bytecode stack */ + char *stack; + char *stack_end; }; struct thread_state commit edb28bf669b890b7498cad0fd818ffa38b5e13a9 Author: Lars Ingebrigtsen Date: Thu Mar 17 16:11:39 2022 +0100 Restore HOME after mailcap-parsing-and-mailcap-mime-info * test/lisp/net/mailcap-tests.el (mailcap-parsing-and-mailcap-mime-info): Restore HOME after the test (bug#54435). diff --git a/test/lisp/net/mailcap-tests.el b/test/lisp/net/mailcap-tests.el index b439c08c79..188706fc86 100644 --- a/test/lisp/net/mailcap-tests.el +++ b/test/lisp/net/mailcap-tests.el @@ -79,45 +79,45 @@ ;; execution errors when running the tests from the Makefile ;; because then HOME=/nonexistent. (ert-with-temp-directory home - (setenv "HOME" home) - ;; Now parse our resource mailcap file. - (mailcap-parse-mailcap (ert-resource-file "mailcap")) - - ;; Assert that we get what we have defined. - (dolist (type '("audio/ogg" "audio/flac")) - (should (string= "mpv %s" (mailcap-mime-info type)))) - (should (string= "aplay %s" (mailcap-mime-info "audio/x-wav"))) - (should (string= "emacsclient -t %s" - (mailcap-mime-info "text/plain"))) - ;; evince is chosen because acroread has test=false and okular - ;; comes later. - (should (string= "evince %s" - (mailcap-mime-info "application/pdf"))) - (should (string= "inkscape %s" - (mailcap-mime-info "image/svg+xml"))) - (should (string= "eog %s" - (mailcap-mime-info "image/jpg"))) - ;; With REQUEST being a number, all fields of the selected entry - ;; should be returned. - (should (equal '((viewer . "evince %s") - (type . "application/pdf")) - (mailcap-mime-info "application/pdf" 1))) - ;; With 'all, all applicable entries should be returned. - (should (equal '(((viewer . "evince %s") - (type . "application/pdf")) - ((viewer . "okular %s") - (type . "application/pdf"))) - (mailcap-mime-info "application/pdf" 'all))) - (let* ((c nil) - (toggle (lambda (_) (setq c (not c))))) - (mailcap-add "audio/ogg" "toggle %s" toggle) - (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))) - ;; The test results are cached, so in order to have the test - ;; re-evaluated, one needs to clear the cache. - (setq mailcap-viewer-test-cache nil) - (should (string= "mpv %s" (mailcap-mime-info "audio/ogg"))) - (setq mailcap-viewer-test-cache nil) - (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))))))) + (with-environment-variables (("HOME" home)) + ;; Now parse our resource mailcap file. + (mailcap-parse-mailcap (ert-resource-file "mailcap")) + + ;; Assert that we get what we have defined. + (dolist (type '("audio/ogg" "audio/flac")) + (should (string= "mpv %s" (mailcap-mime-info type)))) + (should (string= "aplay %s" (mailcap-mime-info "audio/x-wav"))) + (should (string= "emacsclient -t %s" + (mailcap-mime-info "text/plain"))) + ;; evince is chosen because acroread has test=false and okular + ;; comes later. + (should (string= "evince %s" + (mailcap-mime-info "application/pdf"))) + (should (string= "inkscape %s" + (mailcap-mime-info "image/svg+xml"))) + (should (string= "eog %s" + (mailcap-mime-info "image/jpg"))) + ;; With REQUEST being a number, all fields of the selected entry + ;; should be returned. + (should (equal '((viewer . "evince %s") + (type . "application/pdf")) + (mailcap-mime-info "application/pdf" 1))) + ;; With 'all, all applicable entries should be returned. + (should (equal '(((viewer . "evince %s") + (type . "application/pdf")) + ((viewer . "okular %s") + (type . "application/pdf"))) + (mailcap-mime-info "application/pdf" 'all))) + (let* ((c nil) + (toggle (lambda (_) (setq c (not c))))) + (mailcap-add "audio/ogg" "toggle %s" toggle) + (should (string= "toggle %s" (mailcap-mime-info "audio/ogg"))) + ;; The test results are cached, so in order to have the test + ;; re-evaluated, one needs to clear the cache. + (setq mailcap-viewer-test-cache nil) + (should (string= "mpv %s" (mailcap-mime-info "audio/ogg"))) + (setq mailcap-viewer-test-cache nil) + (should (string= "toggle %s" (mailcap-mime-info "audio/ogg")))))))) (defvar mailcap--test-result nil) (defun mailcap--test-viewer () commit 52dd3fcf89c441be64a94eefa01b704c9aba5090 Author: Michael Albinus Date: Thu Mar 17 15:32:01 2022 +0100 Enable Tramp reloading * lisp/net/tramp.el (tramp-file-name): Add ;;;###tramp-autoload cookie. (Bug#50869) * test/lisp/net/tramp-tests.el (tramp-test47-unload): Do not skip. Test reload. diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 49778cbfee..38bdfab192 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -1421,7 +1421,10 @@ calling HANDLER.") ;; internal data structure. Convenience functions for internal ;; data structure. -;; The basic structure for remote file names. +;; The basic structure for remote file names. We must autoload it in +;; tramp-loaddefs.el, because some functions, which need it, wouldn't +;; work otherwise when unloading / reloading Tramp. (Bug#50869) +;;;###tramp-autoload (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index afe7a74063..f34fdbdaf7 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -7265,7 +7265,6 @@ process sentinels. They shall not disturb each other." "Check that Tramp and its subpackages unload completely. Since it unloads Tramp, it shall be the last test to run." :tags '(:expensive-test) - (skip-unless noninteractive) ;; We have autoloaded objects from tramp.el and tramp-archive.el. ;; In order to remove them, we first need to load both packages. (require 'tramp) @@ -7331,7 +7330,13 @@ Since it unloads Tramp, it shall be the last test to run." (and (string-match-p "^tramp" (symbol-name fun)) (ert-fail (format "Function `%s' still contains Tramp advice" x)))) - x))))) + x)))) + + ;; Reload. + (require 'tramp) + (require 'tramp-archive) + (should (featurep 'tramp)) + (should (featurep 'tramp-archive))) (defun tramp-test-all (&optional interactive) "Run all tests for \\[tramp]. commit 693484d36b1326aebd895314570167ca8da87d69 Author: Stefan Monnier Date: Thu Mar 17 10:07:35 2022 -0400 * lisp/emacs-lisp/cl-generic.el (cl-defgeneric): Warn suspicious args diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index b44dda6f9d..7b11c0c815 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -262,6 +262,16 @@ DEFAULT-BODY, if present, is used as the body of a default method. (declarations nil) (methods ()) (options ()) + (warnings + (let ((nonsymargs + (delq nil (mapcar (lambda (arg) (unless (symbolp arg) arg)) + args)))) + (when nonsymargs + (list + (macroexp-warn-and-return + (format "Non-symbol arguments to cl-defgeneric: %s" + (mapconcat #'prin1-to-string nonsymargs "")) + nil nil nil nonsymargs))))) next-head) (while (progn (setq next-head (car-safe (car options-and-methods))) (or (keywordp next-head) @@ -284,6 +294,7 @@ DEFAULT-BODY, if present, is used as the body of a default method. (setq name (gv-setter (cadr name)))) `(prog1 (progn + ,@warnings (defalias ',name (cl-generic-define ',name ',args ',(nreverse options)) ,(if (consp doc) ;An expression rather than a constant. commit e55ceca8c787c84ed43e5be3c6dbe3d7aad14f8b Author: Lars Ingebrigtsen Date: Thu Mar 17 15:04:07 2022 +0100 Avoid repeated prompts in `M-x shell' if using ~/.emacs_bash * lisp/shell.el (shell): Use `shell-eval-command' to avoid repeated prompts (bug#9961). diff --git a/lisp/shell.el b/lisp/shell.el index 7d5cb475eb..565ededa1e 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -783,17 +783,26 @@ Make the shell buffer the current buffer, and return it. (getenv "ESHELL") shell-file-name)) (name (file-name-nondirectory prog)) (startfile (concat "~/.emacs_" name)) - (xargs-name (intern-soft (concat "explicit-" name "-args")))) + (xargs-name (intern-soft (concat "explicit-" name "-args"))) + (start-point (point))) (unless (file-exists-p startfile) (setq startfile (locate-user-emacs-file (concat "init_" name ".sh")))) (setq-local shell--start-prog (file-name-nondirectory prog)) (apply #'make-comint-in-buffer "shell" buffer prog - (if (file-exists-p startfile) startfile) + nil (if (and xargs-name (boundp xargs-name)) (symbol-value xargs-name) '("-i"))) - (shell-mode)))) + (shell-mode) + (when (file-exists-p startfile) + ;; Wait until the prompt has appeared. + (while (= start-point (point)) + (sleep-for 0.1)) + (shell-eval-command + (with-temp-buffer + (insert-file-contents startfile) + (buffer-string))))))) buffer) ;;; Directory tracking commit 55e18e5649bd2a3783e89413ccfd633d12b8f165 Author: Lars Ingebrigtsen Date: Thu Mar 17 14:50:05 2022 +0100 Make shell-resync-dirs work with zsh * lisp/shell.el (shell-resync-dirs): Use shell-eval-command to avoid getting confused by zsh (bug#54384). (shell-eval-command): New function. diff --git a/lisp/shell.el b/lisp/shell.el index 6198214abe..7d5cb475eb 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -1026,77 +1026,45 @@ this feature; see the function `dirtrack-mode'." "Resync the buffer's idea of the current directory stack. This command queries the shell with the command bound to `shell-dirstack-query' (default \"dirs\"), reads the next -line output and parses it to form the new directory stack. -DON'T issue this command unless the buffer is at a shell prompt. -Also, note that if some other subprocess decides to do output -immediately after the query, its output will be taken as the -new directory stack -- you lose. If this happens, just do the -command again." +line output and parses it to form the new directory stack." (interactive) - (let* ((proc (get-buffer-process (current-buffer))) - (pmark (process-mark proc)) - (started-at-pmark (= (point) (marker-position pmark)))) - (save-excursion - (goto-char pmark) - ;; If the process echoes commands, don't insert a fake command in - ;; the buffer or it will appear twice. - (unless comint-process-echoes - (insert shell-dirstack-query) (insert "\n")) - (sit-for 0) ; force redisplay - (comint-send-string proc shell-dirstack-query) - (comint-send-string proc "\n") - (set-marker pmark (point)) - (let ((pt (point)) - (regexp - (concat - (if comint-process-echoes - ;; Skip command echo if the process echoes - (concat "\\(" (regexp-quote shell-dirstack-query) "\n\\)") - "\\(\\)") - "\\(.+\n\\)"))) - ;; This extra newline prevents the user's pending input from spoofing us. - (insert "\n") (backward-char 1) - ;; Wait for one line. - (while (not (looking-at regexp)) - (accept-process-output proc) - (goto-char pt))) - (goto-char pmark) (delete-char 1) ; remove the extra newline - ;; That's the dirlist. Grab it & parse it. - (let* ((dls (buffer-substring-no-properties - (match-beginning 0) (1- (match-end 0)))) - (dlsl nil) - (pos 0) - (ds nil)) - ;; Split the dirlist into whitespace and non-whitespace chunks. - ;; dlsl will be a reversed list of tokens. - (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos) - (push (match-string 1 dls) dlsl) - (setq pos (match-end 1))) - - ;; Prepend trailing entries until they form an existing directory, - ;; whitespace and all. Discard the next whitespace and repeat. - (while dlsl - (let ((newelt "") - tem1 tem2) - (while newelt - ;; We need tem1 because we don't want to prepend - ;; `comint-file-name-prefix' repeatedly into newelt via tem2. - (setq tem1 (pop dlsl) - tem2 (concat comint-file-name-prefix tem1 newelt)) - (cond ((file-directory-p tem2) - (push tem2 ds) - (when (string= " " (car dlsl)) - (pop dlsl)) - (setq newelt nil)) - (t - (setq newelt (concat tem1 newelt))))))) - - (with-demoted-errors "Couldn't cd: %s" - (shell-cd (car ds)) - (setq shell-dirstack (cdr ds) - shell-last-dir (car shell-dirstack)) - (shell-dirstack-message)))) - (if started-at-pmark (goto-char (marker-position pmark))))) + (let* ((dls (car + (last + (string-lines + (string-chop-newline + (shell-eval-command (concat shell-dirstack-query "\n"))))))) + (dlsl nil) + (pos 0) + (ds nil)) + ;; Split the dirlist into whitespace and non-whitespace chunks. + ;; dlsl will be a reversed list of tokens. + (while (string-match "\\(\\S-+\\|\\s-+\\)" dls pos) + (push (match-string 1 dls) dlsl) + (setq pos (match-end 1))) + + ;; Prepend trailing entries until they form an existing directory, + ;; whitespace and all. Discard the next whitespace and repeat. + (while dlsl + (let ((newelt "") + tem1 tem2) + (while newelt + ;; We need tem1 because we don't want to prepend + ;; `comint-file-name-prefix' repeatedly into newelt via tem2. + (setq tem1 (pop dlsl) + tem2 (concat comint-file-name-prefix tem1 newelt)) + (cond ((file-directory-p tem2) + (push tem2 ds) + (when (string= " " (car dlsl)) + (pop dlsl)) + (setq newelt nil)) + (t + (setq newelt (concat tem1 newelt))))))) + + (with-demoted-errors "Couldn't cd: %s" + (shell-cd (car ds)) + (setq shell-dirstack (cdr ds) + shell-last-dir (car shell-dirstack)) + (shell-dirstack-message)))) ;; For your typing convenience: (defalias 'dirs 'shell-resync-dirs) @@ -1431,6 +1399,36 @@ Returns t if successful." (point-max) (shell--prompt-begin-position)))))) +(defun shell-eval-command (command) + "Eval COMMAND in the current shell process and return the result." + (let* ((proc (get-buffer-process (current-buffer))) + (old-filter (process-filter proc)) + (result "") + prev) + (unwind-protect + (progn + (set-process-filter + proc + (lambda (_proc string) + (setq result (concat result string)))) + (process-send-string proc command) + ;; Wait until we get a prompt (which will be a line without + ;; a newline). This is far from fool-proof -- if something + ;; outputs incomplete data and then sleeps, we'll think + ;; we've received the prompt. + (while (not (let* ((lines (string-lines result)) + (last (car (last lines)))) + (and (length> lines 0) + (not (equal last "")) + (or (not prev) + (not (equal last prev))) + (setq prev last)))) + (accept-process-output proc 0 100))) + ;; Restore old filter. + (set-process-filter proc old-filter)) + ;; Remove the prompt. + (replace-regexp-in-string "\n.*\\'" "\n" result))) + (provide 'shell) ;;; shell.el ends here commit 81bcad03e93854087ab239f4e8b7c062fb069ca5 Author: Stefan Monnier Date: Thu Mar 17 09:54:41 2022 -0400 (seq-contains-p): Refine the non-nil returned value * lisp/emacs-lisp/seq.el (seq-contains-p): Like `cl-some` return the value returned by the test function rather than t. diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index 5ea9fae2e9..1bcb844d8e 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -418,8 +418,9 @@ Equality is defined by TESTFN if non-nil or by `equal' if nil." Equality is defined by TESTFN if non-nil or by `equal' if nil." (catch 'seq--break (seq-doseq (e sequence) - (when (funcall (or testfn #'equal) e elt) - (throw 'seq--break t))) + (let ((r (funcall (or testfn #'equal) e elt))) + (when r + (throw 'seq--break r)))) nil)) (cl-defgeneric seq-set-equal-p (sequence1 sequence2 &optional testfn) commit 11492259b1a7bfd9a8615ffe7148323e9e568d47 Author: Eli Zaretskii Date: Thu Mar 17 14:55:59 2022 +0200 ; * doc/lispref/display.texi (Overlay Arrow): More accurate text. diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 8a138588d3..c82523132e 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -4504,14 +4504,15 @@ about to be executed. This feature has nothing to do with @defvar overlay-arrow-string This variable holds the string to display to call attention to a particular line, or @code{nil} if the arrow feature is not in use. -On a graphical display the contents of the string are ignored; instead a -glyph is displayed in the fringe area to the left of the display area. +On a graphical display the contents of the string are ignored if the +left fringe is shown; instead a glyph is displayed in the fringe area +to the left of the display area. @end defvar @defvar overlay-arrow-position This variable holds a marker that indicates where to display the overlay arrow. It should point at the beginning of a line. On a non-graphical -display the arrow text +display, or when the left fringe is not shown, the arrow text appears at the beginning of that line, overlaying any text that would otherwise appear. Since the arrow is usually short, and the line usually begins with indentation, normally nothing significant is @@ -4543,11 +4544,12 @@ this list. Each variable on this list can have properties @code{overlay-arrow-string} and @code{overlay-arrow-bitmap} that -specify an overlay arrow string (for text terminals) or fringe bitmap -(for graphical terminals) to display at the corresponding overlay -arrow position. If either property is not set, the default -@code{overlay-arrow-string} or @code{overlay-arrow} fringe indicator -is used. +specify an overlay arrow string (for text terminals or graphical +terminals without the left fringe shown) or fringe bitmap +(for graphical terminals with a left fringe) to display at the +corresponding overlay arrow position. If either property is not set, +the default @code{overlay-arrow-string} or @code{overlay-arrow} fringe +indicator is used. @node Scroll Bars commit 6ed3f04e5a3c8aee40a26805bb00cdd070eba319 Author: Philipp Stephani Date: Wed Mar 16 00:10:08 2022 +0100 Fix a use of 'cl-defgeneric'. * lisp/progmodes/xref.el (xref-match-length): Use 'cl-defmethod' instead of 'cl-defgeneric'. diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index a5e6edf951..5d1ba4eaf5 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -227,7 +227,7 @@ This behavior is new in Emacs 28.") "A match xref item describes a search result." length) -(cl-defgeneric xref-match-length ((item xref-match-item)) +(cl-defmethod xref-match-length ((item xref-match-item)) "Return the length of the match." (xref-match-item-length item)) commit 06488ded6b9d8b4971e2e6c5b98b4fab6fe2d167 Author: Lars Ingebrigtsen Date: Thu Mar 17 12:55:24 2022 +0100 Make `?' work again in read-multiple-choice * lisp/emacs-lisp/rmc.el (read-multiple-choice): Make the `?' key work again to show the help text. diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index c450505dfd..195035e6be 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -169,8 +169,9 @@ Usage example: \\='((?a \"always\") (?s \"session only\") (?n \"no\")))" - (let* ((choices (if show-help choices (append choices '((?? "?"))))) - (altered-names (mapcar #'rmc--add-key-description choices)) + (let* ((prompt-choices + (if show-help choices (append choices '((?? "?"))))) + (altered-names (mapcar #'rmc--add-key-description prompt-choices)) (full-prompt (format "%s (%s): " @@ -181,7 +182,7 @@ Usage example: (save-excursion (if show-help (setq buf (rmc--show-help prompt help-string show-help - choices altered-names))) + choices altered-names))) (while (not tchar) (message "%s%s" (if wrong-char @@ -200,7 +201,7 @@ Usage example: (lambda (elem) (cons (capitalize (cadr elem)) (car elem))) - choices))) + prompt-choices))) (condition-case nil (let ((cursor-in-echo-area t)) (read-event)) @@ -238,7 +239,7 @@ Usage example: (when wrong-char (ding)) (setq buf (rmc--show-help prompt help-string show-help - choices altered-names)))))) + choices altered-names)))))) (when (buffer-live-p buf) (kill-buffer buf)) (assq tchar choices))) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index ed30d82c3b..385b0fe44a 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -86,7 +86,6 @@ a: [A]aa b: [B]bb c: [C]cc a really long description of ccc - \n?: [?] -"))))) + \n"))))) ;;; rmc-tests.el ends here commit 6bbd1cc5c9cd3db40dcb1ce82f478473b1f78131 Author: Felician Nemeth Date: Thu Mar 17 12:44:43 2022 +0100 Format long help texts better in read-multiple-choice * lisp/emacs-lisp/rmc.el (rmc--show-help): Format long help texts better (bug#54430). diff --git a/lisp/emacs-lisp/rmc.el b/lisp/emacs-lisp/rmc.el index e635c7f200..c450505dfd 100644 --- a/lisp/emacs-lisp/rmc.el +++ b/lisp/emacs-lisp/rmc.el @@ -112,9 +112,15 @@ (goto-char start) (dolist (line (split-string text "\n")) (end-of-line) - (if (bolp) - (insert line "\n") - (insert line)) + (if (not (bolp)) + (insert line) + (insert (make-string + (max (- (* (mod (1- times) columns) + (+ fill-column 4)) + (current-column)) + 0) + ?\s)) + (insert line "\n")) (forward-line 1)))))))) buf)) diff --git a/test/lisp/emacs-lisp/rmc-tests.el b/test/lisp/emacs-lisp/rmc-tests.el index c1c46d6400..ed30d82c3b 100644 --- a/test/lisp/emacs-lisp/rmc-tests.el +++ b/test/lisp/emacs-lisp/rmc-tests.el @@ -66,5 +66,27 @@ (should (equal (list char str) (read-multiple-choice "Do it? " '((?y "yes") (?n "no")))))))) -(provide 'rmc-tests) +(ert-deftest test-read-multiple-choice-help () + (let ((chars '(?o ?a)) + help) + (cl-letf* (((symbol-function #'read-event) + (lambda () + (message "chars %S" chars) + (when (= 1 (length chars)) + (with-current-buffer "*Multiple Choice Help*" + (setq help (buffer-string)))) + (pop chars)))) + (read-multiple-choice + "Choose:" + '((?a "aaa") + (?b "bbb") + (?c "ccc" "a really long description of ccc"))) + (should (equal help "Choose: + +a: [A]aa b: [B]bb c: [C]cc + a really long + description of ccc + \n?: [?] +"))))) + ;;; rmc-tests.el ends here commit 7fef2e04b219f25c64db0e83ec6f4ae707fb7f83 Author: Andrew G Cohen Date: Fri Mar 4 16:44:40 2022 +0800 Improve propagation of gnus/nnselect group info * lisp/gnus/nnselect.el (nnselect-push-info): Speed up pushing the nnselect info back to the originating groups. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index 586dec65af..d6289f1339 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -878,6 +878,9 @@ article came from is also searched." ;; When the backend can store marks we collect any ;; changes. Unlike a normal group the mark lists only ;; include marks for articles we retrieved. + (when (and (gnus-check-backend-function + 'request-set-mark gnus-newsgroup-name) + (not (gnus-article-unpropagatable-p type))) (let* ((old (range-list-intersection artlist (alist-get type (gnus-info-marks group-info)))) @@ -889,7 +892,7 @@ article came from is also searched." ;; This shouldn't happen, but is a sanity check. (setq del (range-intersection (gnus-active artgroup) del)) - (push (list del 'del (list type)) delta-marks))) + (push (list del 'del (list type)) delta-marks)))) ;; Marked sets are of mark-type 'tuple, 'list, or ;; 'range. We merge the lists with what is already in @@ -914,12 +917,15 @@ article came from is also searched." (setq list (cdr all)))) ;; now merge with the original list and sort just to ;; make sure - (setq list - (sort (map-merge - 'alist list - (alist-get type (gnus-info-marks group-info))) - (lambda (elt1 elt2) - (< (car elt1) (car elt2)))))) + (setq + list (sort + (map-merge + 'alist list + (delq nil + (mapcar + (lambda (x) (unless (memq (car x) artlist) x)) + (alist-get type (gnus-info-marks group-info))))) + 'car-less-than-car))) (t (setq list (range-compress-list @@ -963,9 +969,13 @@ article came from is also searched." (cdr (assoc artgroup select-reads))) (sort (cdr (assoc artgroup select-unreads)) #'<)))) (gnus-get-unread-articles-in-group - group-info (gnus-active artgroup) t) - (gnus-group-update-group artgroup t t))))))) - + group-info (gnus-active artgroup) t)) + (gnus-group-update-group + artgroup t + (equal group-info + (setq group-info (copy-sequence (gnus-get-info artgroup)) + group-info + (delq (gnus-info-params group-info) group-info))))))))) (declare-function gnus-registry-get-id-key "gnus-registry" (id key)) commit 90040f0e9f0d2a8fd2a8b1bc7904bb1db05470b0 Author: Andrew G Cohen Date: Fri Mar 4 16:29:50 2022 +0800 Fix bug in nnselect fetching new articles in a thread * lisp/gnus/nnselect.el (nnselect-request-thread): Ignore the Retrieval Status Value in comparing whether articles are the same. diff --git a/lisp/gnus/nnselect.el b/lisp/gnus/nnselect.el index c880d79840..586dec65af 100644 --- a/lisp/gnus/nnselect.el +++ b/lisp/gnus/nnselect.el @@ -652,8 +652,15 @@ If this variable is nil, or if the provided function returns nil, (lambda (article) (if (setq seq - (cl-position article - gnus-newsgroup-selection :test 'equal)) + (cl-position + article + gnus-newsgroup-selection + :test + (lambda (x y) + (and (equal (nnselect-artitem-group x) + (nnselect-artitem-group y)) + (eql (nnselect-artitem-number x) + (nnselect-artitem-number y)))))) (push (1+ seq) old-arts) (setq gnus-newsgroup-selection (vconcat gnus-newsgroup-selection (vector article))) commit da0d598190c3337c4acb2adb7435b756c655af87 Author: Sean Whitton Date: Thu Mar 17 11:57:14 2022 +0100 Don't use the original sender's address as the envelope-from * lisp/gnus/message.el (message-resend): Avoid setting the envelope-from to the original sender's address rather than the resender's (bug#54429). diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index 2e9242d3e1..30734b8f1a 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -50,6 +50,7 @@ (require 'subr-x) (require 'yank-media) (require 'mailcap) +(require 'sendmail) (autoload 'mailclient-send-it "mailclient") @@ -8016,7 +8017,18 @@ is for the internal use." (select-safe-coding-system-function nil) message-required-mail-headers message-generate-hashcash - rfc2047-encode-encoded-words) + rfc2047-encode-encoded-words + ;; If `message-sendmail-envelope-from' is `header' then + ;; the envelope-from will be the original sender's + ;; address, not the resender's. But when resending, the + ;; envelope-from should be the resender's address. Defuse + ;; that particular case. + (message-sendmail-envelope-from + (and (not (and (eq message-sendmail-envelope-from + 'obey-mail-envelope-from) + (eq mail-envelope-from 'header))) + (not (eq message-sendmail-envelope-from 'header)) + message-sendmail-envelope-from))) (message-send-mail)) (when gcc (message-goto-eoh) commit 1d3b7474c7d79ae5f38b5dcb7a44f4975b3e79e8 Author: Arash Esbati Date: Thu Mar 17 11:44:15 2022 +0100 Improve LaTeX symbol prettification * lisp/textmodes/tex-mode.el (tex--prettify-symbols-alist): Support macros which used to be part of textcomp package. diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index aa6fd24518..da4d7cc442 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -3563,28 +3563,122 @@ There might be text before point." ("\\ordmasculine" . ?º) ("\\lambdabar" . ?ƛ) ("\\celsius" . ?℃) + ;; Text symbols formerly part of textcomp package: + ("\\textdollar" . ?$) + ("\\textborn" . ?*) + ("\\textless" . ?<) + ("\\textgreater" . ?>) + ("\\textbackslash" . ?\\) + ("\\textasciicircum" . ?^) + ("\\textunderscore" . ?_) + ("\\textbraceleft" . ?\{) + ("\\textbar" . ?|) + ("\\textbraceright" . ?\}) + ("\\textasciitilde" . ?~) + ("\\textexclamdown" . ?¡) + ("\\textcent" . ?¢) + ("\\textsterling" . ?£) + ("\\textcurrency" . ?¤) + ("\\textyen" . ?¥) + ("\\textbrokenbar" . ?¦) + ("\\textsection" . ?§) + ("\\textasciidieresis" . ?¨) + ("\\textcopyright" . ?©) + ("\\textordfeminine" . ?ª) + ("\\guillemetleft" . ?«) + ("\\guillemotleft" . ?«) + ("\\textlnot" . ?¬) + ("\\textregistered" . ?®) + ("\\textasciimacron" . ?¯) + ("\\textdegree" . ?°) + ("\\textpm" . ?±) + ("\\texttwosuperior" . ?²) + ("\\textthreesuperior" . ?³) + ("\\textasciiacute" . ?´) ("\\textmu" . ?µ) + ("\\textparagraph" . ?¶) + ("\\textpilcrow" . ?¶) + ("\\textperiodcentered" . ?·) + ("\\textonesuperior" . ?¹) + ("\\textordmasculine" . ?º) + ("\\guillemetright" . ?») + ("\\guillemotright" . ?») + ("\\textonequarter" . ?¼) + ("\\textonehalf" . ?½) + ("\\textthreequarters" . ?¾) + ("\\textquestiondown" . ?¿) + ("\\texttimes" . ?×) + ("\\textdiv" . ?÷) + ("\\textflorin" . ?ƒ) + ("\\textasciicaron" . ?ˇ) + ("\\textasciibreve" . ?˘) + ("\\textacutedbl" . ?˝) + ("\\textgravedbl" . 757) + ("\\texttildelow" . 759) + ("\\textbaht" . ?฿) + ("\\textendash" . ?–) + ("\\textemdash" . ?—) + ("\\textbardbl" . ?‖) + ("\\textquoteleft" . 8216) + ("\\textquoteright" . 8217) + ("\\quotesinglbase" . 8218) + ("\\textquotedblleft" . 8220) + ("\\textquotedblright" . 8221) + ("\\quotedblbase" . 8222) + ;; \textdagger and \textdied are replaced with DAGGER (#x2020) and + ;; not with LATIN CROSS (#x271d) + ("\\textdagger" . ?†) + ("\\textdied" . ?†) + ("\\textdaggerdbl" . ?‡) + ("\\textbullet" . ?•) + ("\\textellipsis" . ?…) + ("\\textperthousand" . ?‰) + ("\\textpertenthousand" . ?‱) + ("\\guilsinglleft" . ?‹) + ("\\guilsinglright" . ?›) + ("\\textreferencemark" . ?※) + ("\\textinterrobang" . ?‽) ("\\textfractionsolidus" . ?⁄) - ("\\textbigcircle" . ?⃝) - ("\\textmusicalnote" . ?♪) - ("\\textdied" . ?✝) + ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation + ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation + ("\\textdiscount" . ?⁒) ("\\textcolonmonetary" . ?₡) - ("\\textwon" . ?₩) + ("\\textlira" . ?₤) ("\\textnaira" . ?₦) + ("\\textwon" . ?₩) + ("\\textdong" . ?₫) + ("\\texteuro" . ?€) ("\\textpeso" . ?₱) - ("\\textlira" . ?₤) - ("\\textrecipe" . ?℞) - ("\\textinterrobang" . ?‽) - ("\\textpertenthousand" . ?‱) - ("\\textbaht" . ?฿) + ("\\textguarani" . ?₲) + ("\\textcelsius" . ?℃) ("\\textnumero" . ?№) - ("\\textdiscount" . ?⁒) + ("\\textcircledP" . ?℗) + ("\\textrecipe" . ?℞) + ("\\textservicemark" . ?℠) + ("\\texttrademark" . ?™) + ("\\textohm" . ?Ω) + ("\\textmho" . ?℧) ("\\textestimated" . ?℮) + ("\\textleftarrow" . ?←) + ("\\textuparrow" . ?↑) + ("\\textrightarrow" . ?→) + ("\\textdownarrow" . ?↓) + ("\\textminus" . ?−) + ("\\textsurd" . ?√) + ("\\textlangle" . 9001) ; Literal ?〈 breaks indentation + ("\\textrangle" . 9002) ; Literal ?〉 breaks indentation + ("\\textblank" . ?␢) + ("\\textvisiblespace" . ?␣) ("\\textopenbullet" . ?◦) - ("\\textlquill" . 8261) ; Literal ?⁅ breaks indentation. - ("\\textrquill" . 8262) ; Literal ?⁆ breaks indentation. - ("\\textcircledP" . ?℗) - ("\\textreferencemark" . ?※)) + ;; \textbigcircle is replaced with LARGE CIRCLE (#x25ef) and not + ;; with COMBINING ENCLOSING CIRCLE (#x20dd) + ("\\textbigcircle" . ?◯) + ("\\textmusicalnote" . ?♪) + ("\\textmarried" . ?⚭) + ("\\textdivorced" . ?⚮) + ("\\textlbrackdbl" . 10214) ; Literal ?⟦ breaks indentation + ("\\textrbrackdbl" . 10215) ; Literal ?⟧ breaks indentation + ("\\textinterrobangdown" . ?⸘)) "A `prettify-symbols-alist' usable for (La)TeX modes.") (defun tex--prettify-symbols-compose-p (_start end _match) commit 140d7cc9cbb9da0a2494110105909b1cb8c92998 Author: Po Lu Date: Thu Mar 17 17:41:41 2022 +0800 Prevent invisible frames from acting as drag sources * src/xterm.c (x_dnd_begin_drag_and_drop): Error out if f is invisible. It makes no sense for an invisible frame to be a drag source, so the function just hangs. diff --git a/src/xterm.c b/src/xterm.c index 1b0b3ef793..6485374e2a 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1093,6 +1093,9 @@ x_dnd_begin_drag_and_drop (struct frame *f, Time time, Atom xaction, char *atom_name; Lisp_Object action, ltimestamp; + if (!FRAME_VISIBLE_P (f)) + error ("Frame is invisible"); + if (x_dnd_in_progress) error ("A drag-and-drop session is already in progress"); commit 51bf066b30131c8bcbc0592f1b7363bcecfee334 Author: Po Lu Date: Thu Mar 17 09:14:53 2022 +0000 * src/haikuselect.c (Fhaiku_drag_message): Clear display grab after drag ends. diff --git a/src/haikuselect.c b/src/haikuselect.c index 322e01f791..7474ff1232 100644 --- a/src/haikuselect.c +++ b/src/haikuselect.c @@ -522,6 +522,7 @@ drag will originate. */) be_drag_message (FRAME_HAIKU_VIEW (f), be_message, block_input, unblock_input, process_pending_signals); + FRAME_DISPLAY_INFO (f)->grabbed = 0; return unbind_to (idx, Qnil); } commit bc17a10708337cbe853ea153bd82ad159d959924 Author: Po Lu Date: Thu Mar 17 08:51:32 2022 +0000 Fix creating frames with an initial value of `fullscreen' on Haiku * src/haikufns.c (haiku_create_frame): Set configury_done and do pending fullscreen change if any. * src/haikuterm.c (haiku_fullscreen): Defer actually setting fullscreen until configury_done is set. * src/haikuterm.h (struct haiku_output): New field `configury_done'. diff --git a/src/haikufns.c b/src/haikufns.c index 24e4613e3e..7bb613af6e 100644 --- a/src/haikufns.c +++ b/src/haikufns.c @@ -902,6 +902,11 @@ haiku_create_frame (Lisp_Object parms) BWindow_center_on_screen (FRAME_HAIKU_WINDOW (f)); unblock_input (); + FRAME_OUTPUT_DATA (f)->configury_done = true; + + if (f->want_fullscreen != FULLSCREEN_NONE) + FRAME_TERMINAL (f)->fullscreen_hook (f); + /* Make sure windows on this frame appear in calls to next-window and similar functions. */ Vwindow_list = Qnil; diff --git a/src/haikuterm.c b/src/haikuterm.c index 9844a09a02..4ae64129ef 100644 --- a/src/haikuterm.c +++ b/src/haikuterm.c @@ -3779,6 +3779,13 @@ haiku_toggle_invisible_pointer (struct frame *f, bool invisible_p) static void haiku_fullscreen (struct frame *f) { + /* When FRAME_OUTPUT_DATA (f)->configury_done is false, the frame is + being created, and its regular width and height have not yet been + set. This function will be called again by haiku_create_frame, + so do nothing. */ + if (!FRAME_OUTPUT_DATA (f)->configury_done) + return; + if (f->want_fullscreen == FULLSCREEN_MAXIMIZED) { EmacsWindow_make_fullscreen (FRAME_HAIKU_WINDOW (f), 0); diff --git a/src/haikuterm.h b/src/haikuterm.h index 8d0af8dc67..65fd51e237 100644 --- a/src/haikuterm.h +++ b/src/haikuterm.h @@ -165,6 +165,10 @@ struct haiku_output /* The pending position we're waiting for. */ int pending_top, pending_left; + + /* Whether or not adjust_frame_size and haiku_set_offset have yet + been called by haiku_create_frame. */ + bool configury_done; }; struct x_output commit 22239f2141afdaf18127730f8e5c128c620a55b7 Author: Michael Albinus Date: Thu Mar 17 09:09:54 2022 +0100 Do not cache directories with Tramp sshfs * lisp/net/tramp-sshfs.el (tramp-methods) : Add "-o dir_cache=no" to `tramp-mount-args'. (Bug#54126) diff --git a/lisp/net/tramp-sshfs.el b/lisp/net/tramp-sshfs.el index 2f9d8a0681..9dcb6259fb 100644 --- a/lisp/net/tramp-sshfs.el +++ b/lisp/net/tramp-sshfs.el @@ -51,6 +51,7 @@ (add-to-list 'tramp-methods `(,tramp-sshfs-method (tramp-mount-args (("-C") ("-p" "%p") + ("-o" "dir_cache=no") ("-o" "transform_symlinks") ("-o" "idmap=user,reconnect"))) ;; These are for remote processes. commit 4fc585418bd557a0920556c76be4c1b3dda62219 Author: Po Lu Date: Thu Mar 17 07:17:13 2022 +0000 Fix mouse movement on Haiku * src/haiku_support.cc (MouseMoved): Make sure grab view exists before comparing against it. diff --git a/src/haiku_support.cc b/src/haiku_support.cc index f8acd2a4ec..8c45a7adcb 100644 --- a/src/haiku_support.cc +++ b/src/haiku_support.cc @@ -1459,7 +1459,7 @@ class EmacsView : public BView if (!grab_view_locker.Lock ()) gui_abort ("Couldn't lock grab view locker"); - if (this != grab_view) + if (grab_view && this != grab_view) { grab_view_locker.Unlock (); return; commit 13762d24b88a370f349d308c48b28b94bcbbad18 Author: Po Lu Date: Thu Mar 17 15:12:23 2022 +0800 Display drag-and-drop messages in echo area on non-graphics displays * lisp/mouse.el (mouse-drag-and-drop-region-display-tooltip) (mouse-drag-and-drop-region-hide-tooltip): New functions. (mouse-drag-and-drop-region): Use them instead of calling `x-hide-tip' and `x-show-tip' directly. diff --git a/lisp/mouse.el b/lisp/mouse.el index 3e7ae24697..93c89de91c 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -2991,6 +2991,21 @@ highlight the original region when (declare-function rectangle-intersect-p "rect" (pos1 size1 pos2 size2)) (declare-function x-begin-drag "xfns.c") +(defun mouse-drag-and-drop-region-display-tooltip (tooltip) + "Display TOOLTIP, a tooltip string, using `x-show-tip'. +Call `tooltip-show-help-non-mode' instead on non-graphical displays." + (if (display-graphic-p) + (x-show-tip tooltip) + (tooltip-show-help-non-mode tooltip))) + +(defun mouse-drag-and-drop-region-hide-tooltip () + "Hide any tooltip currently displayed. +Call `tooltip-show-help-non-mode' to clear the echo area message +instead on non-graphical displays." + (if (display-graphic-p) + (x-hide-tip) + (tooltip-show-help-non-mode nil))) + (defun mouse-drag-and-drop-region (event) "Move text in the region to point where mouse is dragged to. The transportation of text is also referred as `drag and drop'. @@ -3087,6 +3102,7 @@ is copied instead of being cut." (throw 'loop t))))))) (when (and mouse-drag-and-drop-region-cross-program + (display-graphic-p) (fboundp 'x-begin-drag) (framep (posn-window (event-end event))) (let ((location (posn-x-y (event-end event))) @@ -3097,7 +3113,7 @@ is copied instead of being cut." (frame-pixel-width frame)) (> (cdr location) (frame-pixel-height frame))))) - (x-hide-tip) + (mouse-drag-and-drop-region-hide-tooltip) (gui-set-selection 'XdndSelection value-selection) (let ((drag-action-or-frame (x-begin-drag '("UTF8_STRING" "text/plain" @@ -3183,8 +3199,8 @@ is copied instead of being cut." ;; which change the text properties, and ;; `text-tooltip' can potentially be the text which ;; will be pasted. - (x-show-tip text-tooltip) - (x-hide-tip)) + (mouse-drag-and-drop-region-display-tooltip text-tooltip) + (mouse-drag-and-drop-region-hide-tooltip)) ;; Show cursor and highlight the original region. (when mouse-drag-and-drop-region-show-cursor