commit e0b9944b69ff72923c29756fcfcea9528a3f5069 (HEAD, refs/remotes/origin/master) Author: João Távora Date: Thu Dec 21 14:49:02 2023 -0600 Jsonrpc: overhaul logging mechanics * lisp/jsonrpc.el (jsonrpc-connection): Rework. (initialize-instance :after jsonrpc-connection): New method. (slot-missing jsonrpc-connection :events-buffer-scrollback-size oset): New hack. (jsonrpc-connection-receive): Rework. (initialize-instance :after jsonrpc-process-connection): Rework from non-after version. (jsonrpc-connection-send) (jsonrpc--call-deferred) (jsonrpc--process-sentinel) (jsonrpc--async-request-1, jsonrpc--debug, jsonrpc--log-event) (jsonrpc--forwarding-buffer): Rework. (jsonrpc--run-event-hook): New helper. (jsonrpc-event-hook): New hook. * lisp/progmodes/eglot.el (eglot-lsp-server): Fix project slot initform. (eglot--connect): Use new jsonrpc-connection initarg. * test/lisp/progmodes/eglot-tests.el (eglot--sniffing): Use jsonrpc-event-hook. (eglot-test-basic-completions): Fix test. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 8b34728fb95..453452b4520 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -71,16 +71,15 @@ jsonrpc-connection (-request-continuations :initform nil :accessor jsonrpc--request-continuations - :documentation "An alist of request IDs to continuation lambdas.") + :documentation "An alist of request IDs to continuation specs.") (-events-buffer :initform nil :accessor jsonrpc--events-buffer :documentation "A buffer pretty-printing the JSONRPC events") - (-events-buffer-scrollback-size - :initform nil - :initarg :events-buffer-scrollback-size - :accessor jsonrpc--events-buffer-scrollback-size - :documentation "Max size of events buffer. 0 disables, nil means infinite.") + (-events-buffer-config + :initform '(:size nil :format full) + :initarg :events-buffer-config + :documentation "Plist configuring the events buffer functions.") (-deferred-actions :initform (make-hash-table :test #'equal) :accessor jsonrpc--deferred-actions @@ -98,7 +97,7 @@ jsonrpc-connection :accessor jsonrpc--next-request-id :documentation "Next number used for a request")) :documentation "Base class representing a JSONRPC connection. -The following initargs are accepted: +The following keyword argument initargs are accepted: :NAME (mandatory), a string naming the connection @@ -112,7 +111,33 @@ jsonrpc-connection :NOTIFICATION-DISPATCHER (optional), a function of three arguments (CONN METHOD PARAMS) for handling JSONRPC notifications. CONN, METHOD and PARAMS are the same as in -:REQUEST-DISPATCHER.") +:REQUEST-DISPATCHER. + +:EVENTS-BUFFER-CONFIG is a plist. Its `:size' stipulates the +size of the log buffer (0 disables, nil means infinite). The +`:format' property is a symbol for choosing the log entry format.") + +(cl-defmethod initialize-instance :after + ((c jsonrpc-connection) ((&key (events-buffer-scrollback-size + nil + e-b-s-s-supplied-p) + &allow-other-keys) + t)) + (when e-b-s-s-supplied-p + (warn + "`:events-buffer-scrollback-size' deprecated. Use `events-buffer-config'.") + (with-slots ((plist -events-buffer-config)) c + (setf plist (copy-sequence plist) + plist (plist-put plist :size events-buffer-scrollback-size))))) + +(cl-defmethod slot-missing ((_c jsonrpc-connection) + (_n (eql :events-buffer-scrollback-size)) + (_op (eql oset)) + _) + ;; Yuck! But this just coerces EIEIO to backward-compatibly accept + ;; the :e-b-s-s initarg that is no longer associated with a slot + ;; #pineForCLOS.. + ) ;;; API mandatory (cl-defgeneric jsonrpc-connection-send (conn &key id method params result error) @@ -169,7 +194,10 @@ jsonrpc-convert-from-endpoint JSONRPC message." ;; TODO: describe representations and serialization in manual and ;; link here. - (:method (_s remote-message) remote-message)) + (:method (_s remote-message) + (cl-loop for (k v) on remote-message by #'cddr + unless (eq k :jsonrpc-json) + collect k and collect v))) ;;; Convenience @@ -207,48 +235,64 @@ jsonrpc-connection-receive "Process MESSAGE just received from CONN. This function will destructure MESSAGE and call the appropriate dispatcher in CONN." - (cl-destructuring-bind (&key method id error params result _jsonrpc) + (cl-destructuring-bind (&rest whole &key method id error params result _jsonrpc) (jsonrpc-convert-from-endpoint conn message) - (jsonrpc--log-event conn message 'server - (cond ((and method id) 'request) - (method 'notification) - (id 'reply))) - (with-slots (last-error - (rdispatcher -request-dispatcher) - (ndispatcher -notification-dispatcher) - (sr-alist -sync-request-alist)) - conn - (setf last-error error) - (cond - (;; A remote request - (and method id) - (let* ((debug-on-error (and debug-on-error - (not jsonrpc-inhibit-debug-on-error))) - (reply - (condition-case-unless-debug _ignore - (condition-case oops - `(:result ,(funcall rdispatcher conn (intern method) params)) - (jsonrpc-error - `(:error - (:code - ,(or (alist-get 'jsonrpc-error-code (cdr oops)) -32603) - :message ,(or (alist-get 'jsonrpc-error-message - (cdr oops)) - "Internal error"))))) - (error - '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply conn id method reply))) - (;; A remote notification - method - (funcall ndispatcher conn (intern method) params)) - (;; A remote response, but it can't run yet, because there's an - ;; outstanding sync request (bug#67945) - (and id sr-alist (not (eq id (caar sr-alist)))) - (push (cons (jsonrpc--remove conn id) (list result error)) - (cdr (car sr-alist)))) - (;; A remote response that can run - (jsonrpc--continue conn id result error)))) - (jsonrpc--call-deferred conn))) + (unwind-protect + (with-slots (last-error + (rdispatcher -request-dispatcher) + (ndispatcher -notification-dispatcher) + (sr-alist -sync-request-alist)) + conn + (setf last-error error) + (cond + (;; A remote request + (and method id) + (let* ((debug-on-error (and debug-on-error + (not jsonrpc-inhibit-debug-on-error))) + (reply + (condition-case-unless-debug _ignore + (condition-case oops + `(:result ,(funcall rdispatcher conn (intern method) + params)) + (jsonrpc-error + `(:error + (:code + ,(or (alist-get 'jsonrpc-error-code (cdr oops)) + -32603) + :message ,(or (alist-get 'jsonrpc-error-message + (cdr oops)) + "Internal error"))))) + (error + '(:error (:code -32603 :message "Internal error")))))) + (apply #'jsonrpc--reply conn id method reply))) + (;; A remote notification + method + (funcall ndispatcher conn (intern method) params)) + (id + (let ((cont + ;; remove the continuation + (jsonrpc--remove conn id))) + (pcase-let ((`(,_ ,method ,_ ,_ ,_) cont)) + (if (keywordp method) + (setq method (substring (symbol-name method) 1))) + (setq whole (plist-put whole :method method))) + (cond (;; A remote response, but it can't run yet, + ;; because there's an outstanding sync request + ;; (bug#67945) + (and sr-alist (not (eq id (caar sr-alist)))) + (push (cons cont (list result error)) + (cdr (car sr-alist)))) + (;; A remote response that can run + (jsonrpc--continue conn id cont result error))))))) + (jsonrpc--run-event-hook + conn 'server + :json (plist-get message :jsonrpc-json) + :kind (cond ((and method id) 'request) + (method 'notification) + (id 'reply)) + :message whole + :foreign-message message) + (jsonrpc--call-deferred conn)))) ;;; Contacting the remote endpoint @@ -369,10 +413,11 @@ jsonrpc-request ;; to protect against user-quit (C-g) or the ;; `cancel-on-input' case. (pcase-let* ((`(,id ,_) id-and-timer)) + ;; Discard the continuation (jsonrpc--remove connection id (list deferred (current-buffer))) ;; We still call `jsonrpc--continue' to run any ;; "anxious" continuations. - (jsonrpc--continue connection id nil nil))))) + (jsonrpc--continue connection id))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error (cons @@ -426,8 +471,7 @@ jsonrpc-process-connection :ON-SHUTDOWN (optional), a function of one argument, the connection object, called when the process dies.") -(cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots) - (cl-call-next-method) +(cl-defmethod initialize-instance :after ((conn jsonrpc-process-connection) slots) (cl-destructuring-bind (&key ((:process proc)) name &allow-other-keys) slots ;; FIXME: notice the undocumented bad coupling in the stderr ;; buffer name, it must be named exactly like this we expect when @@ -437,7 +481,7 @@ initialize-instance ;; `after-change-functions'. Alternatively, we need a new initarg ;; (but maybe not a slot). (let* ((stderr-buffer-name (format "*%s stderr*" name)) - (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr]" conn)) + (stderr-buffer (jsonrpc--forwarding-buffer stderr-buffer-name "[stderr] " conn)) (hidden-name (concat " " stderr-buffer-name))) ;; If we are correctly coupled to the client, the process now ;; created should pick up the `stderr-buffer' just created, which @@ -475,15 +519,17 @@ jsonrpc-connection-send _partial) "Send MESSAGE, a JSON object, to CONNECTION." (when method - (plist-put args :method - (cond ((keywordp method) (substring (symbol-name method) 1)) - ((symbolp method) (symbol-name method)) - ((stringp method) method) - (t (error "[jsonrpc] invalid method %s" method))))) - (let* ((subtype (cond ((or result-supplied-p error) 'reply) + ;; sanitize method into a string + (setq args + (plist-put args :method + (cond ((keywordp method) (substring (symbol-name method) 1)) + ((symbolp method) (symbol-name method)) + ((stringp method) method) + (t (error "[jsonrpc] invalid method %s" method)))))) + (let* ((kind (cond ((or result-supplied-p error) 'reply) (id 'request) (method 'notification))) - (converted (jsonrpc-convert-to-endpoint connection args subtype)) + (converted (jsonrpc-convert-to-endpoint connection args kind)) (json (jsonrpc--json-encode converted)) (headers `(("Content-Length" . ,(format "%d" (string-bytes json))) @@ -494,7 +540,13 @@ jsonrpc-connection-send (cl-loop for (header . value) in headers concat (concat header ": " value "\r\n") into header-section finally return (format "%s\r\n%s" header-section json))) - (jsonrpc--log-event connection converted 'client subtype))) + (jsonrpc--run-event-hook + connection + 'client + :json json + :kind kind + :message args + :foreign-message converted))) (defun jsonrpc-process-type (conn) "Return the `process-type' of JSONRPC connection CONN." @@ -572,20 +624,22 @@ jsonrpc--reply (defun jsonrpc--call-deferred (connection) "Call CONNECTION's deferred actions, who may again defer themselves." (when-let ((actions (hash-table-values (jsonrpc--deferred-actions connection)))) - (jsonrpc--debug connection `(:maybe-run-deferred - ,(mapcar (apply-partially #'nth 2) actions))) + (jsonrpc--run-event-hook + connection 'internal + :log-text (format "re-attempting deffered requests %s" + (mapcar (apply-partially #'nth 2) actions))) (mapc #'funcall (mapcar #'car actions)))) (defun jsonrpc--process-sentinel (proc change) "Called when PROC undergoes CHANGE." (let ((connection (process-get proc 'jsonrpc-connection))) - (jsonrpc--debug connection `(:message "Connection state changed" :change ,change)) + (jsonrpc--debug connection "Connection state change: `%s'" change) (when (not (process-live-p proc)) (with-current-buffer (jsonrpc-events-buffer connection) (let ((inhibit-read-only t)) (insert "\n----------b---y---e---b---y---e----------\n"))) ;; Cancel outstanding timers - (mapc (jsonrpc-lambda (_id _success _error timer) + (mapc (jsonrpc-lambda (_id _method _success-fn _error-fn timer) (when timer (cancel-timer timer))) (jsonrpc--request-continuations connection)) (maphash (lambda (_ triplet) @@ -595,8 +649,8 @@ jsonrpc--process-sentinel (process-put proc 'jsonrpc-sentinel-cleanup-started t) (unwind-protect ;; Call all outstanding error handlers - (mapc (jsonrpc-lambda (_id _success error _timer) - (funcall error '(:code -1 :message "Server died"))) + (mapc (jsonrpc-lambda (_id _method _success-fn error-fn _timer) + (funcall error-fn '(:code -1 :message "Server died"))) (jsonrpc--request-continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) @@ -657,6 +711,9 @@ jsonrpc--process-filter (cdr oops) (buffer-string)) nil))) (when message + (setq message + (plist-put message :jsonrpc-json + (buffer-string))) (process-put proc 'jsonrpc-mqueue (nconc (process-get proc 'jsonrpc-mqueue) @@ -692,21 +749,22 @@ jsonrpc--remove (with-slots ((conts -request-continuations) (defs -deferred-actions)) conn (if deferred-spec (remhash deferred-spec defs)) (when-let ((ass (assq id conts))) - (cancel-timer (elt (cdr ass) 2)) + (cl-destructuring-bind (_ _ _ _ timer) ass + (cancel-timer timer)) (setf conts (delete ass conts)) ass))) -(defun jsonrpc--schedule (conn id success-fn error-fn timer) - (push (list id success-fn error-fn timer) +(defun jsonrpc--schedule (conn id method success-fn error-fn timer) + (push (list id method success-fn error-fn timer) (jsonrpc--request-continuations conn))) -(defun jsonrpc--continue (conn id result error) - (pcase-let* ((`(,cont-id ,success-fn ,error-fn ,_timer) - (jsonrpc--remove conn id)) +(defun jsonrpc--continue (conn id &optional cont result error) + (pcase-let* ((`(,cont-id ,_method ,success-fn ,error-fn ,_timer) + cont) (head (pop (jsonrpc--sync-request-alist conn))) (anxious (cdr head))) (cond (anxious - (unless (= (car head) id) + (when (not (= (car head) id)) ; sanity check (error "internal error: please report this bug")) ;; If there are "anxious" `jsonrpc-request' continuations ;; that should already have been run, they should run now. @@ -719,7 +777,7 @@ jsonrpc--continue (if error (later error-fn error) (later success-fn result))) (cl-loop for (acont ares aerr) in anxious - for (_id success-fn error-fn) = acont + for (_id _method success-fn error-fn) = acont if aerr do (later error-fn aerr) else do (later success-fn ares)))) (cont-id @@ -760,17 +818,20 @@ jsonrpc--async-request-1 (lambda () (jsonrpc--remove connection id (list deferred buf)) (if timeout-fn (funcall timeout-fn) - (jsonrpc--debug - connection `(:timed-out ,method :id ,id - :params ,params))))))))))) + (jsonrpc--run-event-hook + connection 'internal + :log-text (format "timed-out '%s' (id=%s)" method id) + :id id)))))))))) (when deferred (if (jsonrpc-connection-ready-p connection deferred) ;; Server is ready, we jump below and send it immediately. (remhash (list deferred buf) (jsonrpc--deferred-actions connection)) ;; Otherwise, save in `jsonrpc--deferred-actions' and exit non-locally (unless old-id - (jsonrpc--debug connection `(:deferring ,method :id ,id :params - ,params))) + (jsonrpc--run-event-hook + connection 'internal + :log-text (format "deferring '%s' (id=%s)" method id) + :id id)) (puthash (list deferred buf) (list (lambda () (when (buffer-live-p buf) @@ -793,22 +854,22 @@ jsonrpc--async-request-1 (when sync-request (push (list id) (jsonrpc--sync-request-alist connection))) - (jsonrpc--schedule connection - id - (or success-fn - (lambda (&rest _ignored) - (jsonrpc--debug - connection (list :message "success ignored" - :id id)))) - (or error-fn - (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--debug - connection (list - :message - (format "error ignored, status set (%s)" - message) - :id id :error code)))) - (funcall maybe-timer)) + (jsonrpc--schedule + connection id method + (or success-fn + (lambda (&rest _ignored) + (jsonrpc--run-event-hook + connection 'internal + :log-text (format "success ignored") + :id id))) + (or error-fn + (jsonrpc-lambda (&key code message &allow-other-keys) + (jsonrpc--run-event-hook + connection 'internal + :log-text (format "error %s ignored: %s ignored" + code message) + :id id))) + (funcall maybe-timer)) (list id timer))) (defun jsonrpc--message (format &rest args) @@ -817,10 +878,11 @@ jsonrpc--message (defun jsonrpc--debug (server format &rest args) "Debug message for SERVER with FORMAT and ARGS." - (jsonrpc--log-event - server (if (stringp format) - `(:message ,(apply #'format format args)) - format))) + (with-current-buffer (jsonrpc-events-buffer server) + (jsonrpc--log-event + server 'internal + :log-text (apply #'format format args) + :type 'debug))) (defun jsonrpc--warn (format &rest args) "Warning message with FORMAT and ARGS." @@ -830,39 +892,97 @@ jsonrpc--warn (apply #'format format args) :warning))) -(defun jsonrpc--log-event (connection message &optional origin subtype) - "Log a JSONRPC-related event. -CONNECTION is the current connection. MESSAGE is a JSON-like -plist. ORIGIN is a symbol saying where event originated. -SUBTYPE tells more about the event." - (let ((max (jsonrpc--events-buffer-scrollback-size connection))) +(cl-defun jsonrpc--run-event-hook (connection + origin + &rest plist + &key _kind _json _message _foreign-message _log-text + &allow-other-keys) + (with-current-buffer (jsonrpc-events-buffer connection) + (run-hook-wrapped 'jsonrpc-event-hook + (lambda (fn) + (apply fn connection origin plist))))) + +(defvar jsonrpc-event-hook (list #'jsonrpc--log-event) + "Hook run when JSON-RPC events are emitted. +This hooks runs in the events buffer of every `jsonrpc-connection' +when an event is originated by either endpoint. Each hook function +is passed the arguments described by the lambda list: + + (CONNECTION ORIGIN &key JSON KIND MESSAGE FOREIGN-MESSAGE LOG-TEXT + &allow-other-keys) + + CONNECTION the `jsonrpc-connection' instance. + ORIGIN one of the symbols `client' ,`server'. + JSON the raw JSON string content. + KIND one of the symbols `request' ,`notification', + `reply'. + MESSAGE a plist representing the exchanged message in + jsonrpc.el's internal format + FOREIGN-MESSAGE a plist representing the exchanged message in + the remote endpoint's format. + LOG-TEXT text used for events of `internal' origin. + ID id of a message that this event refers to. + TYPE `error', `debug' or the default `info'. + +Except for CONNECTION and ORIGIN all other keys are optional. +Unlisted keys may appear in the plist. + +Do not use this hook to write JSON-RPC protocols, use other parts +of the API instead.") + +(cl-defun jsonrpc--log-event (connection origin + &key kind message + foreign-message log-text json + type + &allow-other-keys) + "Log a JSONRPC-related event. Installed in `jsonrpc-event-hook'." + (let* ((props (slot-value connection '-events-buffer-config)) + (max (plist-get props :size)) + (format (plist-get props :format))) (when (or (null max) (cl-plusp max)) - (with-current-buffer (jsonrpc-events-buffer connection) - (cl-destructuring-bind (&key _method id error &allow-other-keys) message - (let* ((inhibit-read-only t) - (type - (concat (format "%s" (or origin 'internal)) - (if origin (format "-%s" (or subtype 'message)))))) - (goto-char (point-max)) - (prog1 - (let ((msg (format "[%s]%s%s %s:\n%s" - type - (if id (format " (id:%s)" id) "") - (if error " ERROR" "") - (current-time-string) - (pp-to-string message)))) - (when error - (setq msg (propertize msg 'face 'error))) - (insert-before-markers msg)) - ;; Trim the buffer if it's too large - (when max - (save-excursion - (goto-char (point-min)) - (while (> (buffer-size) max) - (delete-region (point) (progn (forward-line 1) - (forward-sexp 1) - (forward-line 2) - (point))))))))))))) + (cl-destructuring-bind (&key method id error &allow-other-keys) message + (let* ((inhibit-read-only t) + (depth (length (jsonrpc--sync-request-alist connection))) + (msg + (cond ((eq format 'full) + (format "[jsonrpc] %s[%s]%s %s\n" + (pcase type ('error "E") ('debug "D") (_ "e")) + (format-time-string "%H:%M:%S.%3N") + (if (eq origin 'internal) + "" + (format " %s%s %s%s" + (make-string (* 2 depth) ? ) + (pcase origin + ('client "-->") + ('server "<--") + (_ "")) + (or method "") + (if id (format "(%s)" id) ""))) + (or json log-text))) + (t + (format "[%s]%s%s %s:\n%s" + (concat (format "%s" (or origin 'internal)) + (if origin (format "-%s" (or kind 'message)))) + (if id (format " (id:%s)" id) "") + (if error " ERROR" "") + (format-time-string "%H:%M:%S.%3N") + (if foreign-message (pp-to-string foreign-message) + log-text)))))) + (goto-char (point-max)) + ;; XXX: could use `run-at-time' to delay server logs + ;; slightly to play nice with verbose servers' stderr. + (when error + (setq msg (propertize msg 'face 'error))) + (insert-before-markers msg) + ;; Trim the buffer if it's too large + (when max + (save-excursion + (goto-char (point-min)) + (while (> (buffer-size) max) + (delete-region (point) (progn (forward-line 1) + (forward-sexp 1) + (forward-line 2) + (point))))))))))) (defun jsonrpc--forwarding-buffer (name prefix conn) "Helper for `jsonrpc-process-connection' helpers. @@ -885,7 +1005,9 @@ jsonrpc--forwarding-buffer do (with-current-buffer (jsonrpc-events-buffer conn) (goto-char (point-max)) (let ((inhibit-read-only t)) - (insert (format "%s %s\n" prefix line)))) + (insert + (propertize (format "%s %s\n" prefix line) + 'face 'shadow)))) until (eobp))) nil t)) (current-buffer))) diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 2a3c2201e21..c849ff5c37e 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -993,6 +993,7 @@ eglot-lsp-server :documentation "Flag set when server is shutting down." :accessor eglot--shutdown-requested) (project + :initform nil :documentation "Project associated with server." :accessor eglot--project) (progress-reporters @@ -1512,7 +1513,7 @@ eglot--connect (apply #'make-instance class :name readable-name - :events-buffer-scrollback-size eglot-events-buffer-size + :events-buffer-config `(:size ,eglot-events-buffer-size :format full) :notification-dispatcher (funcall spread #'eglot-handle-notification) :request-dispatcher (funcall spread #'eglot-handle-request) :on-shutdown #'eglot--on-shutdown diff --git a/test/lisp/progmodes/eglot-tests.el b/test/lisp/progmodes/eglot-tests.el index 996ff276e68..f2da3295b49 100644 --- a/test/lisp/progmodes/eglot-tests.el +++ b/test/lisp/progmodes/eglot-tests.el @@ -199,38 +199,40 @@ eglot--sniffing &rest body) "Run BODY saving LSP JSON messages in variables, most recent first." (declare (indent 1) (debug (sexp &rest form))) - (let ((log-event-ad-sym (make-symbol "eglot--event-sniff"))) - `(unwind-protect - (let ,(delq nil (list server-requests - server-notifications - server-replies - client-requests - client-notifications - client-replies)) - (advice-add - #'jsonrpc--log-event :before - (lambda (_proc message &optional origin subtype) - (let ((req-p (eq subtype 'request)) - (notif-p (eq subtype 'notification)) - (reply-p (eql subtype 'reply))) - (cond - ((eq origin 'server) - (cond (req-p ,(when server-requests - `(push message ,server-requests))) - (notif-p ,(when server-notifications - `(push message ,server-notifications))) - (reply-p ,(when server-replies - `(push message ,server-replies))))) - ((eq origin 'client) - (cond (req-p ,(when client-requests - `(push message ,client-requests))) - (notif-p ,(when client-notifications - `(push message ,client-notifications))) - (reply-p ,(when client-replies - `(push message ,client-replies)))))))) - '((name . ,log-event-ad-sym))) - ,@body) - (advice-remove #'jsonrpc--log-event ',log-event-ad-sym)))) + (let ((log-event-hook-sym (make-symbol "eglot--event-sniff"))) + `(let* (,@(delq nil (list server-requests + server-notifications + server-replies + client-requests + client-notifications + client-replies))) + (cl-flet ((,log-event-hook-sym (_connection + origin + &key _json kind message _foreign-message + &allow-other-keys) + (let ((req-p (eq kind 'request)) + (notif-p (eq kind 'notification)) + (reply-p (eql kind 'reply))) + (cond + ((eq origin 'server) + (cond (req-p ,(when server-requests + `(push message ,server-requests))) + (notif-p ,(when server-notifications + `(push message ,server-notifications))) + (reply-p ,(when server-replies + `(push message ,server-replies))))) + ((eq origin 'client) + (cond (req-p ,(when client-requests + `(push message ,client-requests))) + (notif-p ,(when client-notifications + `(push message ,client-notifications))) + (reply-p ,(when client-replies + `(push message ,client-replies))))))))) + (unwind-protect + (progn + (add-hook 'jsonrpc-event-hook #',log-event-hook-sym) + ,@body) + (remove-hook 'jsonrpc-event-hook #',log-event-hook-sym)))))) (cl-defmacro eglot--wait-for ((events-sym &optional (timeout 1) message) args &body body) (declare (indent 2) (debug (sexp sexp sexp &rest form))) @@ -542,10 +544,7 @@ eglot-test-basic-completions `(("project" . (("coiso.c" . "#include \nint main () {fprin")))) (with-current-buffer (eglot--find-file-noselect "project/coiso.c") - (eglot--sniffing (:server-notifications s-notifs) - (eglot--wait-for-clangd) - (eglot--wait-for (s-notifs 20) (&key method &allow-other-keys) - (string= method "textDocument/publishDiagnostics"))) + (eglot--wait-for-clangd) (goto-char (point-max)) (completion-at-point) (message (buffer-string)) commit 4adc67c59dedcea89116aae0e054ea1212dcca7a Author: João Távora Date: Thu Dec 21 09:08:13 2023 -0600 Jsonrpc: fix destructuring bug * lisp/jsonrpc.el (jsonrpc--process-sentinel): Fix destructuring bug. (Version): Bump to 1.0.22 diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 737351e5d7a..8b34728fb95 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.21 +;; Version: 1.0.22 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -585,7 +585,7 @@ jsonrpc--process-sentinel (let ((inhibit-read-only t)) (insert "\n----------b---y---e---b---y---e----------\n"))) ;; Cancel outstanding timers - (mapc (lambda (_id _success _error timer) + (mapc (jsonrpc-lambda (_id _success _error timer) (when timer (cancel-timer timer))) (jsonrpc--request-continuations connection)) (maphash (lambda (_ triplet) @@ -595,7 +595,7 @@ jsonrpc--process-sentinel (process-put proc 'jsonrpc-sentinel-cleanup-started t) (unwind-protect ;; Call all outstanding error handlers - (mapc (lambda (_id _success error _timer) + (mapc (jsonrpc-lambda (_id _success error _timer) (funcall error '(:code -1 :message "Server died"))) (jsonrpc--request-continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) commit 93dea9288a82e00d6dfc97acd554a242b11d1501 Merge: 843cbb9a15a ec898e94b3d Author: Stefan Monnier Date: Thu Dec 21 09:37:12 2023 -0500 Merge branch 'no-ls-lisp-advice' commit ec898e94b3d364d58a3a833c413da005fea2867a (refs/remotes/origin/scratch/no-ls-lisp-advice) Author: Stefan Monnier Date: Thu Dec 21 09:27:53 2023 -0500 * test/lisp/ls-lisp-tests.el (ls-lisp-unload): Delete test We don't use such advice any more. diff --git a/test/lisp/ls-lisp-tests.el b/test/lisp/ls-lisp-tests.el index 8c6262819c4..374028a3d16 100644 --- a/test/lisp/ls-lisp-tests.el +++ b/test/lisp/ls-lisp-tests.el @@ -29,13 +29,6 @@ (require 'ls-lisp) (require 'dired) -(ert-deftest ls-lisp-unload () - "Test for https://debbugs.gnu.org/xxxxx ." - (should (advice-member-p 'ls-lisp--insert-directory 'insert-directory)) - (unload-feature 'ls-lisp 'force) - (should-not (advice-member-p 'ls-lisp--insert-directory 'insert-directory)) - (require 'ls-lisp)) - (ert-deftest ls-lisp-test-bug27762 () "Test for https://debbugs.gnu.org/27762 ." (let* ((dir source-directory) commit 843cbb9a15a93c5f20368d6bc6baa97e65ff27ac Author: Eli Zaretskii Date: Thu Dec 21 15:21:21 2023 +0200 ; * etc/NEWS: Fix markings (bug#67249). diff --git a/etc/NEWS b/etc/NEWS index 689aed30009..b39dd5f5ab6 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1340,6 +1340,7 @@ values. * Lisp Changes in Emacs 30.1 ++++ ** New 'pop-up-frames' action alist entry for 'display-buffer'. This has the same effect as the variable of the same name and takes precedence over the variable when present. commit 25dc93c5c1bc7df82a9e16dd080667ccb4ba4f45 Author: Mattias Engdegård Date: Wed Dec 20 17:08:41 2023 +0100 ; * lisp/emacs-lisp/cconv.el (cconv-convert): Reindent. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 136560f3ef4..1c9b7fc6730 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -330,303 +330,308 @@ cconv-convert ;; so we never touch it(unless we enter to the other closure). ;;(if (listp form) (print (car form)) form) (macroexp--with-extended-form-stack form - (pcase form - (`(,(and letsym (or 'let* 'let)) ,binders . ,body) + (pcase form + (`(,(and letsym (or 'let* 'let)) ,binders . ,body) ; let and let* special forms - (let ((binders-new '()) - (new-env env) - (new-extend extend)) - - (dolist (binder binders) - (let* ((value nil) - (var (if (not (consp binder)) - (prog1 binder (setq binder (list binder))) - (when (cddr binder) - (byte-compile-warn-x - binder - "Malformed `%S' binding: %S" - letsym binder)) - (setq value (cadr binder)) - (car binder)))) - (cond - ;; Ignore bindings without a valid name. - ((not (symbolp var)) - (byte-compile-warn-x var "attempt to let-bind nonvariable `%S'" var)) - ((or (booleanp var) (keywordp var)) - (byte-compile-warn-x var "attempt to let-bind constant `%S'" var)) - (t - (let ((new-val - (pcase (cconv--var-classification binder form) - ;; Check if var is a candidate for lambda lifting. - ((and :lambda-candidate - (guard - (progn - (cl-assert (and (eq (car value) 'function) - (eq (car (cadr value)) 'lambda))) - (cl-assert (equal (cddr (cadr value)) - (caar cconv-freevars-alist))) - ;; Peek at the freevars to decide whether - ;; to λ-lift. - (let* ((fvs (cdr (car cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs))) + (let ((binders-new '()) + (new-env env) + (new-extend extend)) + + (dolist (binder binders) + (let* ((value nil) + (var (if (not (consp binder)) + (prog1 binder (setq binder (list binder))) + (when (cddr binder) + (byte-compile-warn-x + binder + "Malformed `%S' binding: %S" + letsym binder)) + (setq value (cadr binder)) + (car binder)))) + (cond + ;; Ignore bindings without a valid name. + ((not (symbolp var)) + (byte-compile-warn-x + var "attempt to let-bind nonvariable `%S'" var)) + ((or (booleanp var) (keywordp var)) + (byte-compile-warn-x + var "attempt to let-bind constant `%S'" var)) + (t + (let ((new-val + (pcase (cconv--var-classification binder form) + ;; Check if var is a candidate for lambda lifting. + ((and :lambda-candidate + (guard + (progn + (cl-assert + (and (eq (car value) 'function) + (eq (car (cadr value)) 'lambda))) + (cl-assert (equal (cddr (cadr value)) + (caar cconv-freevars-alist))) + ;; Peek at the freevars to decide whether + ;; to λ-lift. + (let* ((fvs (cdr (car cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs))) ; lambda lifting condition - (and fvs (>= cconv-liftwhen - (length funcvars))))))) + (and fvs (>= cconv-liftwhen + (length funcvars))))))) ; Lift. - (let* ((fvs (cdr (pop cconv-freevars-alist))) - (fun (cadr value)) - (funargs (cadr fun)) - (funcvars (append fvs funargs)) - (funcbody (cddr fun)) - (funcbody-env ())) - (push `(,var . (apply-partially ,var . ,fvs)) new-env) - (dolist (fv fvs) - (cl-pushnew fv new-extend) - (if (and (eq 'car-safe (car-safe - (cdr (assq fv env)))) - (not (memq fv funargs))) - (push `(,fv . (car-safe ,fv)) funcbody-env))) - `(function (lambda ,funcvars . - ,(cconv--convert-funcbody - funargs funcbody funcbody-env value))))) - - ;; Check if it needs to be turned into a "ref-cell". - (:captured+mutated - ;; Declared variable is mutated and captured. - (push `(,var . (car-safe ,var)) new-env) - `(list ,(cconv-convert value env extend))) - - ;; Check if it needs to be turned into a "ref-cell". - (:unused - ;; Declared variable is unused. - (if (assq var new-env) - (push `(,var) new-env)) ;FIXME:Needed? - (let* ((Ignore (if (symbol-with-pos-p var) - (position-symbol 'ignore var) - 'ignore)) - (newval `(,Ignore - ,(cconv-convert value env extend))) - (msg (cconv--warn-unused-msg var "variable"))) - (if (null msg) newval - (macroexp--warn-wrap var msg newval 'lexical)))) - - ;; Normal default case. - (_ - (if (assq var new-env) (push `(,var) new-env)) - (cconv-convert value env extend))))) - - (when (and (eq letsym 'let*) (memq var new-extend)) - ;; One of the lambda-lifted vars is shadowed, so add - ;; a reference to the outside binding and arrange to use - ;; that reference. - (let ((var-def (cconv--lifted-arg var env)) - (closedsym (make-symbol (format "closed-%s" var)))) - (setq new-env (cconv--remap-llv new-env var closedsym)) - ;; FIXME: `closedsym' doesn't need to be added to `extend' - ;; but adding it makes it easier to write the assertion at - ;; the beginning of this function. - (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var-def) binders-new))) - - ;; We push the element after redefined free variables are - ;; processed. This is important to avoid the bug when free - ;; variable and the function have the same name. - (push (list var new-val) binders-new) - - (when (eq letsym 'let*) - (setq env new-env) - (setq extend new-extend)))))) - ) ; end of dolist over binders - - (when (not (eq letsym 'let*)) - ;; We can't do the cconv--remap-llv at the same place for let and - ;; let* because in the case of `let', the shadowing may occur - ;; before we know that the var will be in `new-extend' (bug#24171). - (dolist (binder binders-new) - (when (memq (car-safe binder) new-extend) - ;; One of the lambda-lifted vars is shadowed. - (let* ((var (car-safe binder)) - (var-def (cconv--lifted-arg var env)) - (closedsym (make-symbol (format "closed-%s" var)))) - (setq new-env (cconv--remap-llv new-env var closedsym)) - (setq new-extend (cons closedsym (remq var new-extend))) - (push `(,closedsym ,var-def) binders-new))))) - - `(,letsym ,(nreverse binders-new) - . ,(mapcar (lambda (form) - (cconv-convert - form new-env new-extend)) - body)))) + (let* ((fvs (cdr (pop cconv-freevars-alist))) + (fun (cadr value)) + (funargs (cadr fun)) + (funcvars (append fvs funargs)) + (funcbody (cddr fun)) + (funcbody-env ())) + (push `(,var . (apply-partially ,var . ,fvs)) + new-env) + (dolist (fv fvs) + (cl-pushnew fv new-extend) + (if (and (eq 'car-safe (car-safe + (cdr (assq fv env)))) + (not (memq fv funargs))) + (push `(,fv . (car-safe ,fv)) funcbody-env))) + `(function + (lambda ,funcvars + . ,(cconv--convert-funcbody + funargs funcbody funcbody-env value))))) + + ;; Check if it needs to be turned into a "ref-cell". + (:captured+mutated + ;; Declared variable is mutated and captured. + (push `(,var . (car-safe ,var)) new-env) + `(list ,(cconv-convert value env extend))) + + ;; Check if it needs to be turned into a "ref-cell". + (:unused + ;; Declared variable is unused. + (if (assq var new-env) + (push `(,var) new-env)) ;FIXME:Needed? + (let* ((Ignore (if (symbol-with-pos-p var) + (position-symbol 'ignore var) + 'ignore)) + (newval `(,Ignore + ,(cconv-convert value env extend))) + (msg (cconv--warn-unused-msg var "variable"))) + (if (null msg) newval + (macroexp--warn-wrap var msg newval 'lexical)))) + + ;; Normal default case. + (_ + (if (assq var new-env) (push `(,var) new-env)) + (cconv-convert value env extend))))) + + (when (and (eq letsym 'let*) (memq var new-extend)) + ;; One of the lambda-lifted vars is shadowed, so add + ;; a reference to the outside binding and arrange to use + ;; that reference. + (let ((var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + ;; FIXME: `closedsym' doesn't need to be added to `extend' + ;; but adding it makes it easier to write the assertion at + ;; the beginning of this function. + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var-def) binders-new))) + + ;; We push the element after redefined free variables are + ;; processed. This is important to avoid the bug when free + ;; variable and the function have the same name. + (push (list var new-val) binders-new) + + (when (eq letsym 'let*) + (setq env new-env) + (setq extend new-extend)))))) + ) ; end of dolist over binders + + (when (not (eq letsym 'let*)) + ;; We can't do the cconv--remap-llv at the same place for let and + ;; let* because in the case of `let', the shadowing may occur + ;; before we know that the var will be in `new-extend' (bug#24171). + (dolist (binder binders-new) + (when (memq (car-safe binder) new-extend) + ;; One of the lambda-lifted vars is shadowed. + (let* ((var (car-safe binder)) + (var-def (cconv--lifted-arg var env)) + (closedsym (make-symbol (format "closed-%s" var)))) + (setq new-env (cconv--remap-llv new-env var closedsym)) + (setq new-extend (cons closedsym (remq var new-extend))) + (push `(,closedsym ,var-def) binders-new))))) + + `(,letsym ,(nreverse binders-new) + . ,(mapcar (lambda (form) + (cconv-convert + form new-env new-extend)) + body)))) ;end of let let* forms - ; first element is lambda expression - (`(,(and `(lambda . ,_) fun) . ,args) - ;; FIXME: it's silly to create a closure just to call it. - ;; Running byte-optimize-form earlier would resolve this. - `(funcall - ,(cconv-convert `(function ,fun) env extend) - ,@(mapcar (lambda (form) - (cconv-convert form env extend)) - args))) - - (`(cond . ,cond-forms) ; cond special form - `(,(car form) . ,(mapcar (lambda (branch) - (mapcar (lambda (form) - (cconv-convert form env extend)) - branch)) - cond-forms))) - - (`(function (lambda ,args . ,body) . ,rest) - (let* ((docstring (if (eq :documentation (car-safe (car body))) - (cconv-convert (cadr (pop body)) env extend))) - (bf (if (stringp (car body)) (cdr body) body)) - (if (when (eq 'interactive (car-safe (car bf))) - (gethash form cconv--interactive-form-funs))) - (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t) (_ nil))) - (cif (when if (cconv-convert if env extend))) - (cf nil)) - ;; TODO: Because we need to non-destructively modify body, this code - ;; is particularly ugly. This should ideally be moved to - ;; cconv--convert-function. - (pcase cif - ('nil (setq bf nil)) - (`#',f - (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) - (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3))) - (setq cif nil)) - ;; The interactive form needs special treatment, so the form - ;; inside the `interactive' won't be used any further. - (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) - (setq bf `((,f1 . (nil . ,f2)) . ,f3))))) - (when bf - ;; If we modified bf, re-build body and form as - ;; copies with the modified bits. - (setq body (if (stringp (car body)) - (cons (car body) bf) - bf) - form `(function (lambda ,args . ,body) . ,rest)) - ;; Also, remove the current old entry on the alist, replacing - ;; it with the new one. - (let ((entry (pop cconv-freevars-alist))) - (push (cons body (cdr entry)) cconv-freevars-alist))) - (setq cf (cconv--convert-function args body env form docstring)) - (if (not cif) - ;; Normal case, the interactive form needs no special treatment. - cf - `(cconv--interactive-helper - ,cf ,(if wrapped cif `(list 'quote ,cif)))))) - - (`(internal-make-closure . ,_) - (byte-compile-report-error - "Internal error in compiler: cconv called twice?")) - - (`(quote . ,_) form) - (`(function . ,_) form) + ; first element is lambda expression + (`(,(and `(lambda . ,_) fun) . ,args) + ;; FIXME: it's silly to create a closure just to call it. + ;; Running byte-optimize-form earlier would resolve this. + `(funcall + ,(cconv-convert `(function ,fun) env extend) + ,@(mapcar (lambda (form) + (cconv-convert form env extend)) + args))) + + (`(cond . ,cond-forms) ; cond special form + `(,(car form) . ,(mapcar (lambda (branch) + (mapcar (lambda (form) + (cconv-convert form env extend)) + branch)) + cond-forms))) + + (`(function (lambda ,args . ,body) . ,rest) + (let* ((docstring (if (eq :documentation (car-safe (car body))) + (cconv-convert (cadr (pop body)) env extend))) + (bf (if (stringp (car body)) (cdr body) body)) + (if (when (eq 'interactive (car-safe (car bf))) + (gethash form cconv--interactive-form-funs))) + (wrapped (pcase if (`#'(lambda (&rest _cconv--dummy) .,_) t))) + (cif (when if (cconv-convert if env extend))) + (cf nil)) + ;; TODO: Because we need to non-destructively modify body, this code + ;; is particularly ugly. This should ideally be moved to + ;; cconv--convert-function. + (pcase cif + ('nil (setq bf nil)) + (`#',f + (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (,(if wrapped (nth 2 f) cif) . ,f2)) . ,f3))) + (setq cif nil)) + ;; The interactive form needs special treatment, so the form + ;; inside the `interactive' won't be used any further. + (_ (pcase-let ((`((,f1 . (,_ . ,f2)) . ,f3) bf)) + (setq bf `((,f1 . (nil . ,f2)) . ,f3))))) + (when bf + ;; If we modified bf, re-build body and form as + ;; copies with the modified bits. + (setq body (if (stringp (car body)) + (cons (car body) bf) + bf) + form `(function (lambda ,args . ,body) . ,rest)) + ;; Also, remove the current old entry on the alist, replacing + ;; it with the new one. + (let ((entry (pop cconv-freevars-alist))) + (push (cons body (cdr entry)) cconv-freevars-alist))) + (setq cf (cconv--convert-function args body env form docstring)) + (if (not cif) + ;; Normal case, the interactive form needs no special treatment. + cf + `(cconv--interactive-helper + ,cf ,(if wrapped cif `(list 'quote ,cif)))))) + + (`(internal-make-closure . ,_) + (byte-compile-report-error + "Internal error in compiler: cconv called twice?")) + + (`(quote . ,_) form) + (`(function . ,_) form) ;defconst, defvar - (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms) - `(,sym ,definedsymbol - . ,(when (consp forms) - (cons (cconv-convert (car forms) env extend) - ;; The rest (i.e. docstring, of any) is not evaluated, - ;; and may be an invalid expression (e.g. ($# . 678)). - (cdr forms))))) + (`(,(and sym (or 'defconst 'defvar)) ,definedsymbol . ,forms) + `(,sym ,definedsymbol + . ,(when (consp forms) + (cons (cconv-convert (car forms) env extend) + ;; The rest (i.e. docstring, of any) is not evaluated, + ;; and may be an invalid expression (e.g. ($# . 678)). + (cdr forms))))) ; condition-case - (`(condition-case ,var ,protected-form . ,handlers) - (let* ((class (and var (cconv--var-classification (list var) form))) - (newenv - (cond ((eq class :captured+mutated) - (cons `(,var . (car-safe ,var)) env)) - ((assq var env) (cons `(,var) env)) - (t env))) - (msg (when (eq class :unused) - (cconv--warn-unused-msg var "variable"))) - (newprotform (cconv-convert protected-form env extend))) - `(,(car form) ,var - ,(if msg - (macroexp--warn-wrap var msg newprotform 'lexical) - newprotform) - ,@(mapcar - (lambda (handler) - `(,(car handler) - ,@(let ((body - (mapcar (lambda (form) - (cconv-convert form newenv extend)) - (cdr handler)))) - (if (not (eq class :captured+mutated)) - body - `((let ((,var (list ,var))) ,@body)))))) - handlers)))) - - (`(unwind-protect ,form1 . ,body) - `(,(car form) ,(cconv-convert form1 env extend) - :fun-body ,(cconv--convert-function () body env form1))) - - (`(setq ,var ,expr) - (let ((var-new (or (cdr (assq var env)) var)) - (value (cconv-convert expr env extend))) - (pcase var-new - ((pred symbolp) `(,(car form) ,var-new ,value)) - (`(car-safe ,iexp) `(setcar ,iexp ,value)) - ;; This "should never happen", but for variables which are - ;; mutated+captured+unused, we may end up trying to `setq' - ;; on a closed-over variable, so just drop the setq. - (_ ;; (byte-compile-report-error - ;; (format "Internal error in cconv of (setq %s ..)" - ;; sym-new)) - value)))) - - (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args) - ;; These are not special forms but we treat them separately for the needs - ;; of lambda lifting. - (let ((mapping (cdr (assq fun env)))) - (pcase mapping - (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) - (cl-assert (eq (cadr mapping) fun)) - `(,callsym ,fun - ,@(mapcar (lambda (fv) - (let ((exp (or (cdr (assq fv env)) fv))) - (pcase exp - (`(car-safe ,iexp . ,_) iexp) - (_ exp)))) - fvs) - ,@(mapcar (lambda (arg) - (cconv-convert arg env extend)) - args))) - (_ `(,callsym ,@(mapcar (lambda (arg) + (`(condition-case ,var ,protected-form . ,handlers) + (let* ((class (and var (cconv--var-classification (list var) form))) + (newenv + (cond ((eq class :captured+mutated) + (cons `(,var . (car-safe ,var)) env)) + ((assq var env) (cons `(,var) env)) + (t env))) + (msg (when (eq class :unused) + (cconv--warn-unused-msg var "variable"))) + (newprotform (cconv-convert protected-form env extend))) + `(,(car form) ,var + ,(if msg + (macroexp--warn-wrap var msg newprotform 'lexical) + newprotform) + ,@(mapcar + (lambda (handler) + `(,(car handler) + ,@(let ((body + (mapcar (lambda (form) + (cconv-convert form newenv extend)) + (cdr handler)))) + (if (not (eq class :captured+mutated)) + body + `((let ((,var (list ,var))) ,@body)))))) + handlers)))) + + (`(unwind-protect ,form1 . ,body) + `(,(car form) ,(cconv-convert form1 env extend) + :fun-body ,(cconv--convert-function () body env form1))) + + (`(setq ,var ,expr) + (let ((var-new (or (cdr (assq var env)) var)) + (value (cconv-convert expr env extend))) + (pcase var-new + ((pred symbolp) `(,(car form) ,var-new ,value)) + (`(car-safe ,iexp) `(setcar ,iexp ,value)) + ;; This "should never happen", but for variables which are + ;; mutated+captured+unused, we may end up trying to `setq' + ;; on a closed-over variable, so just drop the setq. + (_ ;; (byte-compile-report-error + ;; (format "Internal error in cconv of (setq %s ..)" + ;; sym-new)) + value)))) + + (`(,(and (or 'funcall 'apply) callsym) ,fun . ,args) + ;; These are not special forms but we treat them separately for the needs + ;; of lambda lifting. + (let ((mapping (cdr (assq fun env)))) + (pcase mapping + (`(apply-partially ,_ . ,(and fvs `(,_ . ,_))) + (cl-assert (eq (cadr mapping) fun)) + `(,callsym ,fun + ,@(mapcar (lambda (fv) + (let ((exp (or (cdr (assq fv env)) fv))) + (pcase exp + (`(car-safe ,iexp . ,_) iexp) + (_ exp)))) + fvs) + ,@(mapcar (lambda (arg) (cconv-convert arg env extend)) - (cons fun args))))))) - - ;; The form (if any) is converted beforehand as part of the `lambda' case. - (`(interactive . ,_) form) - - ;; `declare' should now be macro-expanded away (and if they're not, we're - ;; in trouble because they *can* contain code nowadays). - ;; (`(declare . ,_) form) ;The args don't contain code. - - (`(oclosure--fix-type (ignore . ,vars) ,exp) - (dolist (var vars) - (let ((x (assq var env))) - (pcase (cdr x) - (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) - (_ (cl-assert (null (cdr x))))))) - (cconv-convert exp env extend)) - - (`(,func . ,forms) - (if (symbolp func) - ;; First element is function or whatever function-like forms are: - ;; or, and, if, catch, progn, prog1, while, until - `(,func . ,(mapcar (lambda (form) - (cconv-convert form env extend)) - forms)) - (byte-compile-warn-x form "Malformed function `%S'" func) - nil)) - - (_ (or (cdr (assq form env)) form))))) + args))) + (_ `(,callsym ,@(mapcar (lambda (arg) + (cconv-convert arg env extend)) + (cons fun args))))))) + + ;; The form (if any) is converted beforehand as part of the `lambda' case. + (`(interactive . ,_) form) + + ;; `declare' should now be macro-expanded away (and if they're not, we're + ;; in trouble because they *can* contain code nowadays). + ;; (`(declare . ,_) form) ;The args don't contain code. + + (`(oclosure--fix-type (ignore . ,vars) ,exp) + (dolist (var vars) + (let ((x (assq var env))) + (pcase (cdr x) + (`(car-safe . ,_) (error "Slot %S should not be mutated" var)) + (_ (cl-assert (null (cdr x))))))) + (cconv-convert exp env extend)) + + (`(,func . ,forms) + (if (symbolp func) + ;; First element is function or whatever function-like forms are: + ;; or, and, if, catch, progn, prog1, while, until + `(,func . ,(mapcar (lambda (form) + (cconv-convert form env extend)) + forms)) + (byte-compile-warn-x form "Malformed function `%S'" func) + nil)) + + (_ (or (cdr (assq form env)) form))))) (defvar byte-compile-lexical-variables) commit 57fd0f47f6955505195f77a55d29334ded88889c Author: Mattias Engdegård Date: Wed Dec 20 13:21:36 2023 +0100 Maintain byte-compile-form-stack in cconv-convert (bug#67483) * lisp/emacs-lisp/macroexp.el (macroexp--with-extended-form-stack): New. * lisp/emacs-lisp/cconv.el (cconv-closure-convert, cconv-convert): Push forms onto byte-compile-form-stack. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index 0879c2ee63c..136560f3ef4 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -123,7 +123,8 @@ cconv-closure-convert Returns a form where all lambdas don't have any free variables." (let ((cconv--dynbound-variables dynbound-vars) (cconv-freevars-alist '()) - (cconv-var-classification '())) + (cconv-var-classification '()) + (byte-compile-form-stack byte-compile-form-stack)) ;; Analyze form - fill these variables with new information. (cconv-analyze-form form '()) (setq cconv-freevars-alist (nreverse cconv-freevars-alist)) @@ -328,6 +329,7 @@ cconv-convert ;; to find the number of a specific variable in the environment vector, ;; so we never touch it(unless we enter to the other closure). ;;(if (listp form) (print (car form)) form) + (macroexp--with-extended-form-stack form (pcase form (`(,(and letsym (or 'let* 'let)) ,binders . ,body) @@ -624,7 +626,7 @@ cconv-convert (byte-compile-warn-x form "Malformed function `%S'" func) nil)) - (_ (or (cdr (assq form env)) form)))) + (_ (or (cdr (assq form env)) form))))) (defvar byte-compile-lexical-variables) diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 615a6622ce6..2a646be9725 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -39,6 +39,18 @@ byte-compile-form-stack This is to preserve the data in it in the event of a condition-case handling a signaled error.") +(defmacro macroexp--with-extended-form-stack (expr &rest body) + "Evaluate BODY with EXPR pushed onto `byte-compile-form-stack'." + (declare (indent 1)) + ;; FIXME: We really should just be using a simple dynamic let-binding here, + ;; but these explicit push and pop make the extended stack value visible + ;; to error handlers. Remove that need for that! + `(progn + (push ,expr byte-compile-form-stack) + (prog1 + (progn ,@body) + (pop byte-compile-form-stack)))) + ;; Bound by the top-level `macroexpand-all', and modified to include any ;; macros defined by `defmacro'. (defvar macroexpand-all-environment nil) commit 14ecc377ab43e4c33506c2a8b65bf1e75fb262d3 Author: Mattias Engdegård Date: Wed Dec 20 14:15:59 2023 +0100 Non-delayed warning for malformed function (bug#67483) * lisp/emacs-lisp/cconv.el (cconv-convert): Use an immediate warning; a delayed one made little sense as it's a matter of well-formedness. diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e65c39e3998..0879c2ee63c 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -621,9 +621,8 @@ cconv-convert `(,func . ,(mapcar (lambda (form) (cconv-convert form env extend)) forms)) - (macroexp--warn-wrap form (format-message "Malformed function `%S'" - (car form)) - nil nil))) + (byte-compile-warn-x form "Malformed function `%S'" func) + nil)) (_ (or (cdr (assq form env)) form)))) commit ff3965795fb80681111708e104f1edd32bdb6199 Author: Eli Zaretskii Date: Thu Dec 21 13:57:00 2023 +0200 ; * lisp/progmodes/gdb-mi.el (gdb-load-history): Add doc string. diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index cbb165a6a0c..b92514b4d0a 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -818,6 +818,9 @@ gdb--check-interpreter (defvar gdb-control-level 0) (defun gdb-load-history () + "Load GDB history from a history file. +The name of the history file is given by environment variable GDBHISTFILE, +falling back to \".gdb_history\" and \".gdbinit\"." (when (ring-empty-p comint-input-ring) ; cf shell-mode (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE") (if (eq system-type 'ms-dos) commit 63a38fd2921269b6fbacf8a8bbd31b91df8f31a1 Author: Manuel Giraud Date: Wed Dec 20 12:08:30 2023 +0100 Function to load GDB history * lisp/progmodes/gdb-mi.el (gud-gdb-load-history): New function to load GDB history, code factored out of 'gdb'. (gdb): Call it. (Bug#67928) diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index 7ae4bcea1e1..cbb165a6a0c 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -817,6 +817,39 @@ gdb--check-interpreter (defvar gdb-control-level 0) +(defun gdb-load-history () + (when (ring-empty-p comint-input-ring) ; cf shell-mode + (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE") + (if (eq system-type 'ms-dos) + "_gdb_history" + ".gdb_history")))) + ;; gdb defaults to 256, but we'll default to comint-input-ring-size. + (hsize (getenv "HISTSIZE"))) + (dolist (file (append '("~/.gdbinit") + (unless (string-equal (expand-file-name ".") + (expand-file-name "~")) + '(".gdbinit")))) + (if (file-readable-p (setq file (expand-file-name file))) + (with-temp-buffer + (insert-file-contents file) + ;; TODO? check for "set history save\\( *on\\)?" and do + ;; not use history otherwise? + (while (re-search-forward + "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t) + (cond ((string-equal (match-string 1) "filename") + (setq hfile (expand-file-name + (match-string 2) + (file-name-directory file)))) + ((string-equal (match-string 1) "size") + (setq hsize (match-string 2)))))))) + (and (stringp hsize) + (integerp (setq hsize (string-to-number hsize))) + (> hsize 0) + (setq-local comint-input-ring-size hsize)) + (if (stringp hfile) + (setq-local comint-input-ring-file-name hfile)) + (comint-read-input-ring t)))) + ;;;###autoload (defun gdb (command-line) "Run gdb passing it COMMAND-LINE as arguments. @@ -902,37 +935,8 @@ gdb (setq-local gud-minor-mode 'gdbmi) (setq-local gdb-control-level 0) (setq comint-input-sender 'gdb-send) - (when (ring-empty-p comint-input-ring) ; cf shell-mode - (let ((hfile (expand-file-name (or (getenv "GDBHISTFILE") - (if (eq system-type 'ms-dos) - "_gdb_history" - ".gdb_history")))) - ;; gdb defaults to 256, but we'll default to comint-input-ring-size. - (hsize (getenv "HISTSIZE"))) - (dolist (file (append '("~/.gdbinit") - (unless (string-equal (expand-file-name ".") - (expand-file-name "~")) - '(".gdbinit")))) - (if (file-readable-p (setq file (expand-file-name file))) - (with-temp-buffer - (insert-file-contents file) - ;; TODO? check for "set history save\\( *on\\)?" and do - ;; not use history otherwise? - (while (re-search-forward - "^ *set history \\(filename\\|size\\) *\\(.*\\)" nil t) - (cond ((string-equal (match-string 1) "filename") - (setq hfile (expand-file-name - (match-string 2) - (file-name-directory file)))) - ((string-equal (match-string 1) "size") - (setq hsize (match-string 2)))))))) - (and (stringp hsize) - (integerp (setq hsize (string-to-number hsize))) - (> hsize 0) - (setq-local comint-input-ring-size hsize)) - (if (stringp hfile) - (setq-local comint-input-ring-file-name hfile)) - (comint-read-input-ring t))) + (gdb-load-history) + (gud-def gud-tbreak "tbreak %f:%l" "\C-t" "Set temporary breakpoint at current line." t) (gud-def gud-jump commit 7058988fd65d719b69b658a74b268d4a2f1909c5 Author: Eli Zaretskii Date: Thu Dec 21 13:45:58 2023 +0200 Improve and update documentation of registers * lisp/register.el (register-use-preview) (register--read-with-preview-function) (register-preview-function, register-preview-default-1) (register-preview-default, register--preview-function) (register-preview-info, register-command-info) (register-preview-forward-line, register-preview-next) (register-preview-previous, set-register, register-type) (register--type, register-preview, register-preview-1) (register-preview-get-defaults, register-read-with-preview) (register-read-with-preview-traditional) (register-read-with-preview-fancy, register-preview-delay): Doc fixes. * doc/emacs/regs.texi (Registers): Describe the new preview modes. * etc/NEWS: Move the registers entry to its correct place, and document the modified behavior. (Bug#66394) diff --git a/doc/emacs/regs.texi b/doc/emacs/regs.texi index 5e5b7ae2b16..d7542e996dc 100644 --- a/doc/emacs/regs.texi +++ b/doc/emacs/regs.texi @@ -32,14 +32,46 @@ Registers Display a description of what register @var{r} contains. @end table -@vindex register-preview-delay + @cindex preview of registers - All of the commands that prompt for a register will display a -preview window that lists the existing registers (if there are -any) after a short delay. To change the length of the delay, -customize @code{register-preview-delay}. To prevent this display, set -that option to @code{nil}. You can explicitly request a preview -window by pressing @kbd{C-h} or @key{F1}. +@vindex register-use-preview + All of the commands that prompt for a register will by default +display a preview window that lists the existing registers (if there +are any) and their current values, after a short delay. This and +other aspects of prompting for a register can be customized by setting +the value of @code{register-use-preview}, which can have the following +values: + +@table @code +@vindex register-preview-delay +@item traditional +With this value, which is the default, Emacs behaves like it did in +all the versions before Emacs 29: it shows a preview of existing registers +after a delay, and lets you overwrite the values of existing registers +by typing a single character, the name of the register. The preview +appears after the delay determined by the customizable variable +@code{register-preview-delay}, which specifies the delay in seconds; +setting it to @code{nil} disables the preview (but you can still +explicitly request a preview window by pressing @kbd{C-h} or +@key{F1} when Emacs prompts for a register). + +@item t +This value requests a more flexible preview of existing registers. +The preview appears immediately when Emacs prompts for a register +(thus @code{register-preview-delay} has no effect), and the preview +window provides navigation: by using @kbd{C-n} and @kbd{C-p} (or the +@kbd{@key{UP}} and @kbd{@key{DOWN}} arrow keys), you can move between +the registers in the preview window. To overwrite the value of an +existing registers in this mode, you need to type @key{RET} after +selecting the register by navigation or typing its name. + +@item nil +This value requests behavior similar to @code{traditional}, but the +preview is shown without delay. + +@item never +This value is like @code{nil}, but it disables the preview. +@end table @dfn{Bookmarks} record files and positions in them, so you can return to those positions when you look at the file again. Bookmarks diff --git a/etc/NEWS b/etc/NEWS index f96f06af0e2..689aed30009 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -554,6 +554,21 @@ files. *** 'dired-listing-switches' handles connection-local values if exist. This allows to customize different switches for different remote machines. +** Registers + ++++ +*** New mode of prompting for register names and showing preview. +The new user option 'register-use-preview' can be customized to the +value t to request a different user interface of prompting for +register names and previewing the registers: Emacs will require +confirmation for overwriting the value of a register, and will show +the preview of registers without delay. You can also customize this +new option to disable the preview completely. + +The default value of 'register-use-preview' preserves the behavior of +Emacs 29 and before. See the Info node "(emacs) Registers" for more +details about the new UI and its variants. + ** Ediff --- @@ -1216,12 +1231,6 @@ showcases all their customization options. * Incompatible Lisp Changes in Emacs 30.1 ---- -** 'register-preview-delay' is no longer used. -Register preview is no longer delayed. If you want to disable the -preview, customize the new option 'register-use-preview' to the value -'never'. - +++ ** 'M-TAB' now invokes 'completion-at-point' also in Text mode. Text mode no longer binds 'M-TAB' to 'ispell-complete-word', and diff --git a/lisp/register.el b/lisp/register.el index ac4f48d23ce..bd8e8c2edcd 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -96,7 +96,10 @@ register-separator (defcustom register-preview-delay 1 "If non-nil, time to wait in seconds before popping up register preview window. If nil, do not show register previews, unless `help-char' (or a member of -`help-event-list') is pressed." +`help-event-list') is pressed. + +This variable has no effect when `register-use-preview' is set to any +value except \\='traditional." :version "24.4" :type '(choice number (const :tag "No preview unless requested" nil)) :group 'register) @@ -107,35 +110,38 @@ register-preview-default-keys :version "30.1") (defvar register--read-with-preview-function nil - "The register read preview function to use. -Two functions are provided, one that provide navigation and -highlighting of the register selected, filtering of register -according to command in use, defaults register to use when -setting a new register, confirmation and notification when you -are about to overwrite a register and generic functions to -configure how each existing commands behave. The other function -provided is the same as what was used in Emacs-29, no filtering, -no navigation, no defaults.") + "Function to use for reading a register name with preview. +Two functions are provided, one that provide navigation and highlighting +of the selected register, filtering of register according to command in +use, defaults register to use when setting a new register, confirmation +and notification when you are about to overwrite a register, and generic +functions to configure how each existing command behaves. Use the +function `register-read-with-preview-fancy' for this. The other +provided function, `register-read-with-preview-traditional', behaves +the same as in Emacs 29 and before: no filtering, no navigation, +and no defaults.") (defvar register-preview-function nil "Function to format a register for previewing. -Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'. -The function should return a string, the description of the argument. -It is set according to the value of `register--read-with-preview-function'.") +Called with one argument, a cons (NAME . CONTENTS), as found +in `register-alist'. The function should return a string, the +description of the argument. The function to use is set according +to the value of `register--read-with-preview-function'.") (defcustom register-use-preview 'traditional - "Maybe show register preview. - -This has no effect when `register--read-with-preview-function' value -is `register-read-with-preview-traditional'. - -When set to `t' show a preview buffer with navigation and highlighting. -When nil show a preview buffer with no such features and exit minibuffer -immediately after insertion in minibuffer. -When set to \\='never behave as above but with no preview buffer at -all but the preview buffer is still accessible with `help-char' (C-h). -When set to \\='traditional provide a much more basic preview according to -`register-preview-delay', it has the exact same behavior as in Emacs-29." + "Whether to show register preview when modifying registers. + +When set to `t', show a preview buffer with navigation and highlighting. +When nil, show a preview buffer without navigation and highlighting, and +exit the minibuffer immediately after inserting response in minibuffer. +When set to \\='never, behave as with nil, but with no preview buffer at +all; the preview buffer is still accessible with `help-char' (C-h). +When set to \\='traditional (the default), provide a more basic preview +according to `register-preview-delay'; this preserves the traditional +behavior of Emacs 29 and before. + +This has no effect when the value of `register--read-with-preview-function' +is `register-read-with-preview-traditional'." :type '(choice (const :tag "Use preview" t) (const :tag "Use quick preview" nil) @@ -155,7 +161,7 @@ get-register (alist-get register register-alist)) (defun set-register (register value) - "Set contents of Emacs register named REGISTER to VALUE. Return VALUE. + "Set contents of Emacs register named REGISTER to VALUE, return VALUE. See the documentation of the variable `register-alist' for possible VALUEs." (setf (alist-get register register-alist) value)) @@ -169,21 +175,25 @@ register-describe-oneline d))) (defun register-preview-default-1 (r) - "Function that is the default value of the variable `register-preview-function'." + "Function used to format a register for fancy previewing. +This is used as the value of the variable `register-preview-function' +when `register-use-preview' is set to t or nil." (format "%s: %s\n" (propertize (string (car r)) 'display (single-key-description (car r))) (register-describe-oneline (car r)))) (defun register-preview-default (r) - "Function that is the default value of the variable `register-preview-function'." + "Function used to format a register for traditional preview. +This is the default value of the variable `register-preview-function', +and is used when `register-use-preview' is set to \\='traditional." (format "%s: %s\n" (single-key-description (car r)) (register-describe-oneline (car r)))) (cl-defgeneric register--preview-function (read-preview-function) - "Returns a function to format a register for previewing. -This according to the value of READ-PREVIEW-FUNCTION.") + "Return a function to format a register for previewing. +This is according to the value of `read-preview-function'.") (cl-defmethod register--preview-function ((_read-preview-function (eql register-read-with-preview-traditional))) #'register-preview-default) @@ -193,14 +203,15 @@ register--preview-function (cl-defstruct register-preview-info "Store data for a specific register command. -TYPES are the types of register supported. -MSG is the minibuffer message to send when a register is selected. +TYPES are the supported types of registers. +MSG is the minibuffer message to show when a register is selected. ACT is the type of action the command is doing on register. -SMATCH accept a boolean value to say if command accept non matching register." +SMATCH accept a boolean value to say if the command accepts non-matching +registers." types msg act smatch noconfirm) (cl-defgeneric register-command-info (command) - "Returns a `register-preview-info' object storing data for COMMAND." + "Return a `register-preview-info' object storing data for COMMAND." (ignore command)) (cl-defmethod register-command-info ((_command (eql insert-register))) (make-register-preview-info @@ -286,7 +297,7 @@ register-command-info (defun register-preview-forward-line (arg) "Move to next or previous line in register preview buffer. -If ARG is positive goto next line, if negative to previous. +If ARG is positive, go to next line; if negative, go to previous line. Do nothing when defining or executing kmacros." ;; Ensure user enter manually key in minibuffer when recording a macro. (unless (or defining-kbd-macro executing-kbd-macro @@ -315,31 +326,31 @@ register-preview-forward-line (insert str))))))) (defun register-preview-next () - "Goto next line in register preview buffer." + "Go to next line in the register preview buffer." (interactive) (register-preview-forward-line 1)) (defun register-preview-previous () - "Goto previous line in register preview buffer." + "Go to previous line in the register preview buffer." (interactive) (register-preview-forward-line -1)) (defun register-type (register) "Return REGISTER type. -Current register types actually returned are one of: -- string -- number -- marker -- buffer -- file -- file-query -- window -- frame -- kmacro +Register type that can be returned is one of the following: + - string + - number + - marker + - buffer + - file + - file-query + - window + - frame + - kmacro One can add new types to a specific command by defining a new `cl-defmethod' -matching this command. Predicate for type in new `cl-defmethod' should -satisfy `cl-typep' otherwise the new type should be defined with +matching that command. Predicates for type in new `cl-defmethod' should +satisfy `cl-typep', otherwise the new type should be defined with `cl-deftype'." ;; Call register--type against the register value. (register--type (if (consp (cdr register)) @@ -347,7 +358,7 @@ register-type (cdr register)))) (cl-defgeneric register--type (regval) - "Returns type of register value REGVAL." + "Return the type of register value REGVAL." (ignore regval)) (cl-defmethod register--type ((_regval string)) 'string) @@ -371,8 +382,8 @@ register-of-type-alist collect register))) (defun register-preview (buffer &optional show-empty) - "Pop up a window showing the registers preview in BUFFER. -If SHOW-EMPTY is non-nil, show the window even if no registers. + "Pop up a window showing the preview of registers in BUFFER. +If SHOW-EMPTY is non-nil, show the preview window even if no registers. Format of each entry is controlled by the variable `register-preview-function'." (unless register-preview-function (setq register-preview-function (register--preview-function @@ -392,13 +403,13 @@ register-preview register-alist))))) (defun register-preview-1 (buffer &optional show-empty types) - "Pop up a window showing the registers preview in BUFFER. + "Pop up a window showing the preview of registers in BUFFER. -This is the preview function use with -`register-read-with-preview-fancy' function. -If SHOW-EMPTY is non-nil, show the window even if no registers. -Argument TYPES (a list) specify the types of register to show, when nil show all -registers, see `register-type' for suitable types. +This is the preview function used with the `register-read-with-preview-fancy' +function. +If SHOW-EMPTY is non-nil, show the preview window even if no registers. +Optional argument TYPES (a list) specifies the types of register to show; +if it is nil, show all the registers. See `register-type' for suitable types. Format of each entry is controlled by the variable `register-preview-function'." (unless register-preview-function (setq register-preview-function (register--preview-function @@ -419,7 +430,7 @@ register-preview-1 registers)))))) (cl-defgeneric register-preview-get-defaults (action) - "Returns default registers according to ACTION." + "Return default registers according to ACTION." (ignore action)) (cl-defmethod register-preview-get-defaults ((_action (eql set))) (cl-loop for s in register-preview-default-keys @@ -427,19 +438,25 @@ register-preview-get-defaults collect s)) (defun register-read-with-preview (prompt) - "Read and return a register name, possibly showing existing registers. -Prompt with the string PROMPT. + "Read register name, prompting with PROMPT; possibly show existing registers. +This reads and returns the name of a register. PROMPT should be a string +to prompt the user for the name. If `help-char' (or a member of `help-event-list') is pressed, -display such a window regardless." +display preview window unconditionally. +This calls the function specified by `register--read-with-preview-function'." (funcall register--read-with-preview-function prompt)) (defun register-read-with-preview-traditional (prompt) - "Read and return a register name, possibly showing existing registers. -Prompt with the string PROMPT. If `register-alist' and -`register-preview-delay' are both non-nil, display a window -listing existing registers after `register-preview-delay' seconds. + "Read register name, prompting with PROMPT; possibly show existing registers. +This reads and returns the name of a register. PROMPT should be a string +to prompt the user for the name. +If `register-alist' and `register-preview-delay' are both non-nil, display +a window listing existing registers after `register-preview-delay' seconds. If `help-char' (or a member of `help-event-list') is pressed, -display such a window regardless." +display preview window unconditionally. + +This function is used as the value of `register--read-with-preview-function' +when `register-use-preview' is set to \\='traditional." (let* ((buffer "*Register Preview*") (timer (when (numberp register-preview-delay) (run-with-timer register-preview-delay nil @@ -467,10 +484,15 @@ register-read-with-preview-traditional (and (get-buffer buffer) (kill-buffer buffer))))) (defun register-read-with-preview-fancy (prompt) - "Read and return a register name, possibly showing existing registers. -Prompt with the string PROMPT. + "Read register name, prompting with PROMPT; possibly show existing registers. +This reads and returns the name of a register. PROMPT should be a string +to prompt the user for the name. If `help-char' (or a member of `help-event-list') is pressed, -display such a window regardless." +display preview window regardless. + +This function is used as the value of `register--read-with-preview-function' +when `register-use-preview' is set to any value other than \\='traditional +or \\='never." (let* ((buffer "*Register Preview*") (buffer1 "*Register quick preview*") (buf (if register-use-preview buffer buffer1)) commit 04883c36a634c7405e88c1092b694228daf9a199 Author: Po Lu Date: Thu Dec 21 16:31:30 2023 +0800 Implement an undocumented TrueType "feature" * src/sfnt.c (sfnt_move): Correct commentary. (sfnt_interpret_control_value_program): Reset dual projection, freedom and projection vectors, in addition to the reference points, zone pointers and loop counter. diff --git a/src/sfnt.c b/src/sfnt.c index 0e2308bcbac..62ed27b4311 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -10633,7 +10633,7 @@ sfnt_move (sfnt_f26dot6 *restrict x, sfnt_f26dot6 *restrict y, if (versor) { - /* Move along X axis, converting the distance to the freedom + /* Move along Y axis, converting the distance to the freedom vector. */ num = n; k = sfnt_multiply_divide_signed (distance, @@ -12078,6 +12078,38 @@ sfnt_interpret_control_value_program (struct sfnt_interpreter *interpreter, if (interpreter->state.instruct_control & 4) sfnt_init_graphics_state (&interpreter->state); + else + { + /* And even if not, reset the following graphics state + variables, to which both the Apple and MS scalers don't + permit modifications from the preprogram. + + Not only is such reversion undocumented, it is also + inefficient, for modern fonts at large only move points on + the Y axis. As such, these fonts must issue a redundant + SVTCA[Y] instruction within each glyph program, in place of + initializing the projection and freedom vectors once and for + all in prep. Unfortunately many fonts which do instruct on + the X axis now rely on this ill-conceived behavior, so Emacs + must, reluctantly, follow suit. */ + + interpreter->state.dual_projection_vector.x = 040000; /* 1.0 */ + interpreter->state.dual_projection_vector.y = 0; + interpreter->state.freedom_vector.x = 040000; /* 1.0 */ + interpreter->state.freedom_vector.y = 0; + interpreter->state.projection_vector.x = 040000; /* 1.0 */ + interpreter->state.projection_vector.y = 0; + interpreter->state.rp0 = 0; + interpreter->state.rp1 = 0; + interpreter->state.rp2 = 0; + interpreter->state.zp0 = 1; + interpreter->state.zp1 = 1; + interpreter->state.zp2 = 1; + interpreter->state.loop = 1; + + /* Validate the graphics state. */ + sfnt_validate_gs (&interpreter->state); + } /* Save the graphics state upon success. */ memcpy (state, &interpreter->state, sizeof *state); commit e6d8e23ede6d45727c4a0968ec356ac5f9792ba7 Author: Po Lu Date: Thu Dec 21 14:35:18 2023 +0800 * src/sfnt.c (GETINFO): Implement undocumented selector bit 5. diff --git a/src/sfnt.c b/src/sfnt.c index 4d377ddf5e5..0e2308bcbac 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -7605,9 +7605,12 @@ #define SCANCTRL() \ interpreter->state.scan_control = value; \ } -/* Selector bit 8 is undocumented, but present in the Macintosh +/* Selector bit 3 is undocumented, but present in the Macintosh rasterizer. 02000 is returned if there is a variation axis in - use. */ + use. + + Selector bit 5 is undocumented, but relied on by several fonts. + 010000 is returned if a grayscale rasterizer is in use. */ #define GETINFO() \ { \ @@ -7624,6 +7627,9 @@ #define GETINFO() \ && interpreter->norm_coords) \ k |= 02000; \ \ + if (selector & 32) \ + k |= 010000; \ + \ PUSH_UNCHECKED (k); \ } commit 22da40a5e5057c2cdea2f54f1ac590ddc9d831cb Author: Po Lu Date: Thu Dec 21 13:34:54 2023 +0800 Accept empty contours in glyphs * src/sfnt.c (sfnt_decompose_glyph_1, sfnt_decompose_glyph_2): Accept empty contours, for they are not invalid, just redundant. diff --git a/src/sfnt.c b/src/sfnt.c index eb3add7390e..4d377ddf5e5 100644 --- a/src/sfnt.c +++ b/src/sfnt.c @@ -3088,7 +3088,8 @@ sfnt_decompose_glyph_1 (size_t here, size_t last, /* The contour is empty. */ if (here == last) - return 1; + /* An empty contour, if redundant, is not necessarily invalid. */ + return 0; /* Move the pen to the start of the contour. Apparently some fonts have off the curve points as the start of a contour, so when that @@ -3227,7 +3228,8 @@ sfnt_decompose_glyph_2 (size_t here, size_t last, /* The contour is empty. */ if (here == last) - return 1; + /* An empty contour, if redundant, is not necessarily invalid. */ + return 0; /* Move the pen to the start of the contour. Apparently some fonts have off the curve points as the start of a contour, so when that commit 4239c27f3867b558ae2e26950d5153d496b02d8f Author: Stefan Monnier Date: Wed Dec 20 22:38:35 2023 -0500 * lisp/register.el (register-read-with-preview-fancy): Fit in 80 columns diff --git a/lisp/register.el b/lisp/register.el index fe7e9282244..ac4f48d23ce 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -496,13 +496,13 @@ register-read-with-preview-fancy (when (and (memq act '(insert jump view)) (null strs)) (error "No register suitable for `%s'" act)) (dolist (k (cons help-char help-event-list)) - (define-key map - (vector k) (lambda () - (interactive) - ;; Do nothing when buffer1 is in use. - (unless (get-buffer-window buf) - (with-selected-window (minibuffer-selected-window) - (register-preview-1 buffer 'show-empty types)))))) + (define-key map (vector k) + (lambda () + (interactive) + ;; Do nothing when buffer1 is in use. + (unless (get-buffer-window buf) + (with-selected-window (minibuffer-selected-window) + (register-preview-1 buffer 'show-empty types)))))) (define-key map (kbd "") 'register-preview-next) (define-key map (kbd "") 'register-preview-previous) (define-key map (kbd "C-n") 'register-preview-next) @@ -510,67 +510,65 @@ register-read-with-preview-fancy (unless (or executing-kbd-macro (eq register-use-preview 'never)) (register-preview-1 buf nil types)) (unwind-protect - (progn - (minibuffer-with-setup-hook + (let ((setup (lambda () - (add-hook 'post-command-hook - (lambda () + (with-selected-window (minibuffer-window) + (let ((input (minibuffer-contents))) + (when (> (length input) 1) + (let ((new (substring input 1)) + (old (substring input 0 1))) + (setq input (if (or (null smatch) + (member new strs)) + new old)) + (delete-minibuffer-contents) + (insert input))) + (when (and smatch (not (string= input "")) + (not (member input strs))) + (setq input "") + (delete-minibuffer-contents) + (minibuffer-message "Not matching")) + (when (not (string= input pat)) + (setq pat input)))) + (if (setq win (get-buffer-window buffer)) + (with-selected-window win + (let ((ov (make-overlay + (point-min) (point-min))) + ;; Allow upper-case and lower-case letters + ;; to refer to different registers. + (case-fold-search nil)) + (goto-char (point-min)) + (remove-overlays) + (unless (string= pat "") + (if (re-search-forward (concat "^" pat) nil t) + (progn (move-overlay + ov + (match-beginning 0) (pos-eol)) + (overlay-put ov 'face 'match) + (when msg + (with-selected-window + (minibuffer-window) + (minibuffer-message msg pat)))) (with-selected-window (minibuffer-window) - (let ((input (minibuffer-contents))) - (when (> (length input) 1) - (let ((new (substring input 1)) - (old (substring input 0 1))) - (setq input (if (or (null smatch) - (member new strs)) - new old)) - (delete-minibuffer-contents) - (insert input))) - (when (and smatch (not (string= input "")) - (not (member input strs))) - (setq input "") - (delete-minibuffer-contents) - (minibuffer-message "Not matching")) - (when (not (string= input pat)) - (setq pat input)))) - (if (setq win (get-buffer-window buffer)) - (with-selected-window win - (let ((ov (make-overlay - (point-min) (point-min))) - ;; Allow upper-case and - ;; lower-case letters to refer - ;; to different registers. - (case-fold-search nil)) - (goto-char (point-min)) - (remove-overlays) - (unless (string= pat "") - (if (re-search-forward (concat "^" pat) nil t) - (progn (move-overlay - ov - (match-beginning 0) (pos-eol)) - (overlay-put ov 'face 'match) - (when msg - (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)))) - (with-selected-window (minibuffer-window) - (minibuffer-message - "Register `%s' is empty" pat)))))) - (unless (string= pat "") - (with-selected-window (minibuffer-window) - (if (and (member pat strs) - (null noconfirm)) - (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)) - ;; :noconfirm is specifed - ;; explicitely, don't ask for - ;; confirmation and exit immediately (bug#66394). - (setq result pat) - (exit-minibuffer)))))) - nil 'local)) - (setq result (read-from-minibuffer - prompt nil map nil nil (register-preview-get-defaults act)))) - (cl-assert (and result (not (string= result ""))) - nil "No register specified") - (string-to-char result)) + (minibuffer-message + "Register `%s' is empty" pat)))))) + (unless (string= pat "") + (with-selected-window (minibuffer-window) + (if (and (member pat strs) + (null noconfirm)) + (with-selected-window (minibuffer-window) + (minibuffer-message msg pat)) + ;; `:noconfirm' is specified explicitly, don't ask for + ;; confirmation and exit immediately (bug#66394). + (setq result pat) + (exit-minibuffer)))))))) + (minibuffer-with-setup-hook + (lambda () (add-hook 'post-command-hook setup nil 'local)) + (setq result (read-from-minibuffer + prompt nil map nil nil + (register-preview-get-defaults act)))) + (cl-assert (and result (not (string= result ""))) + nil "No register specified") + (string-to-char result)) (let ((w (get-buffer-window buf))) (and (window-live-p w) (delete-window w))) (and (get-buffer buf) (kill-buffer buf))))) commit 3aa9fbf4fab2f21c0a6f0dba510bfe8266578f2f Author: Po Lu Date: Thu Dec 21 09:37:04 2023 +0800 Correct defcustoms in register.el * lisp/register.el (register-preview-default-keys) (register-use-preview): Render :version tags strings. diff --git a/lisp/register.el b/lisp/register.el index c5abcf45109..fe7e9282244 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -104,7 +104,7 @@ register-preview-delay (defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z)) "Default keys for setting a new register." :type '(repeat string) - :version 30.1) + :version "30.1") (defvar register--read-with-preview-function nil "The register read preview function to use. @@ -141,7 +141,7 @@ register-use-preview (const :tag "Use quick preview" nil) (const :tag "Never use preview" never) (const :tag "Basic preview like Emacs-29" traditional)) - :version 30.1 + :version "30.1" :set (lambda (var val) (set var val) (setq register--read-with-preview-function commit 02b99db661861905162a6638349936e784df3189 Author: João Távora Date: Wed Dec 20 16:25:28 2023 -0600 Jsonrpc: deal with nested synchronous jsonrpc-request See bug#67945 * lisp/jsonrpc.el (jsonrpc-connection): Add -sync-request-alist (jsonrpc-connection-receive): Rework. (jsonrpc-request): Rework. Pass SYNC-REQUEST to jsonrpc-async-request-1. (jsonrpc--process-sentinel): Simplify. (jsonrpc--schedule): New helper. (jsonrpc--continue): New helper. (jsonrpc--async-request-1): Rework. (jsonrpc--process-sentinel): Also cancel deferred action timers. (Version): Bump to 1.0.21 diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 936b17929ec..737351e5d7a 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,7 +4,7 @@ ;; Author: João Távora ;; Keywords: processes, languages, extensions -;; Version: 1.0.20 +;; Version: 1.0.21 ;; Package-Requires: ((emacs "25.2")) ;; This is a GNU ELPA :core package. Avoid functionality that is not @@ -87,6 +87,12 @@ jsonrpc-connection :documentation "Map (DEFERRED BUF) to (FN TIMER ID). FN is\ a saved DEFERRED `async-request' from BUF, to be sent not later\ than TIMER as ID.") + (-sync-request-alist ; bug#67945 + :initform nil + :accessor jsonrpc--sync-request-alist + :documentation "List of ((ID [ANXIOUS...])) where ID refers \ +to a sync `jsonrpc-request' and each ANXIOUS to another completed\ +request that is higher up in the stack but couldn't run.") (-next-request-id :initform 0 :accessor jsonrpc--next-request-id @@ -197,18 +203,22 @@ jsonrpc-inhibit-debug-on-error variable can be set around calls like `jsonrpc-request' to circumvent that.") -(defun jsonrpc-connection-receive (connection message) - "Process MESSAGE just received from CONNECTION. +(defun jsonrpc-connection-receive (conn message) + "Process MESSAGE just received from CONN. This function will destructure MESSAGE and call the appropriate -dispatcher in CONNECTION." +dispatcher in CONN." (cl-destructuring-bind (&key method id error params result _jsonrpc) - (jsonrpc-convert-from-endpoint connection message) - (jsonrpc--log-event connection message 'server + (jsonrpc-convert-from-endpoint conn message) + (jsonrpc--log-event conn message 'server (cond ((and method id) 'request) (method 'notification) (id 'reply))) - (let (triplet) - (setf (jsonrpc-last-error connection) error) + (with-slots (last-error + (rdispatcher -request-dispatcher) + (ndispatcher -notification-dispatcher) + (sr-alist -sync-request-alist)) + conn + (setf last-error error) (cond (;; A remote request (and method id) @@ -217,8 +227,7 @@ jsonrpc-connection-receive (reply (condition-case-unless-debug _ignore (condition-case oops - `(:result ,(funcall (jsonrpc--request-dispatcher connection) - connection (intern method) params)) + `(:result ,(funcall rdispatcher conn (intern method) params)) (jsonrpc-error `(:error (:code @@ -228,16 +237,18 @@ jsonrpc-connection-receive "Internal error"))))) (error '(:error (:code -32603 :message "Internal error")))))) - (apply #'jsonrpc--reply connection id method reply))) + (apply #'jsonrpc--reply conn id method reply))) (;; A remote notification method - (funcall (jsonrpc--notification-dispatcher connection) - connection (intern method) params)) - (;; A remote response - (setq triplet (and id (cdr (jsonrpc--remove connection id)))) - (if error (funcall (nth 1 triplet) error) - (funcall (nth 0 triplet) result)))) - (jsonrpc--call-deferred connection)))) + (funcall ndispatcher conn (intern method) params)) + (;; A remote response, but it can't run yet, because there's an + ;; outstanding sync request (bug#67945) + (and id sr-alist (not (eq id (caar sr-alist)))) + (push (cons (jsonrpc--remove conn id) (list result error)) + (cdr (car sr-alist)))) + (;; A remote response that can run + (jsonrpc--continue conn id result error)))) + (jsonrpc--call-deferred conn))) ;;; Contacting the remote endpoint @@ -330,6 +341,7 @@ jsonrpc-request (apply #'jsonrpc--async-request-1 connection method params + :sync-request t :success-fn (lambda (result) (unless canceled (throw tag `(done ,result)))) @@ -357,7 +369,10 @@ jsonrpc-request ;; to protect against user-quit (C-g) or the ;; `cancel-on-input' case. (pcase-let* ((`(,id ,_) id-and-timer)) - (jsonrpc--remove connection id (list deferred (current-buffer))))))) + (jsonrpc--remove connection id (list deferred (current-buffer))) + ;; We still call `jsonrpc--continue' to run any + ;; "anxious" continuations. + (jsonrpc--continue connection id nil nil))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error (cons @@ -570,17 +585,19 @@ jsonrpc--process-sentinel (let ((inhibit-read-only t)) (insert "\n----------b---y---e---b---y---e----------\n"))) ;; Cancel outstanding timers - (mapc (lambda (_id &rest triplet) - (pcase-let ((`(,_success ,_error ,timeout) triplet)) - (when timeout (cancel-timer timeout)))) + (mapc (lambda (_id _success _error timer) + (when timer (cancel-timer timer))) (jsonrpc--request-continuations connection)) + (maphash (lambda (_ triplet) + (pcase-let ((`(,_ ,timer ,_) triplet)) + (when timer (cancel-timer timer)))) + (jsonrpc--deferred-actions connection)) (process-put proc 'jsonrpc-sentinel-cleanup-started t) (unwind-protect ;; Call all outstanding error handlers - (mapc (lambda (_id &rest triplet) - (pcase-let ((`(,_success ,error ,_timeout) triplet)) - (funcall error '(:code -1 :message "Server died")))) - (jsonrpc--request-continuations connection)) + (mapc (lambda (_id _success error _timer) + (funcall error '(:code -1 :message "Server died"))) + (jsonrpc--request-continuations connection)) (jsonrpc--message "Server exited with status %s" (process-exit-status proc)) (delete-process proc) (when-let (p (slot-value connection '-autoport-inferior)) (delete-process p)) @@ -679,14 +696,50 @@ jsonrpc--remove (setf conts (delete ass conts)) ass))) +(defun jsonrpc--schedule (conn id success-fn error-fn timer) + (push (list id success-fn error-fn timer) + (jsonrpc--request-continuations conn))) + +(defun jsonrpc--continue (conn id result error) + (pcase-let* ((`(,cont-id ,success-fn ,error-fn ,_timer) + (jsonrpc--remove conn id)) + (head (pop (jsonrpc--sync-request-alist conn))) + (anxious (cdr head))) + (cond (anxious + (unless (= (car head) id) + (error "internal error: please report this bug")) + ;; If there are "anxious" `jsonrpc-request' continuations + ;; that should already have been run, they should run now. + ;; The main continuation -- if it exists -- should run + ;; before them. This order is important to preserve the + ;; throw to the catch tags in `jsonrpc-request' in + ;; order (bug#67945). + (cl-flet ((later (f arg) (run-at-time 0 nil f arg))) + (when cont-id + (if error (later error-fn error) + (later success-fn result))) + (cl-loop for (acont ares aerr) in anxious + for (_id success-fn error-fn) = acont + if aerr do (later error-fn aerr) + else do (later success-fn ares)))) + (cont-id + ;; Else, just run the normal one, with plain funcall. + (if error (funcall error-fn error) + (funcall success-fn result))) + (t + ;; For clarity. This happens if the `jsonrpc-request' was + ;; cancelled + )))) + (cl-defun jsonrpc--async-request-1 (connection method params &rest args &key success-fn error-fn timeout-fn (timeout jsonrpc-default-request-timeout) - (deferred nil)) - "Does actual work for `jsonrpc-async-request'. + (deferred nil) + (sync-request nil)) + "Helper for `jsonrpc-request' and `jsonrpc-async-request'. Return a list (ID TIMER). ID is the new request's ID, or nil if the request was deferred. TIMER is a timer object set (or nil, if @@ -696,17 +749,20 @@ jsonrpc--async-request-1 (and deferred (gethash (list deferred buf) (jsonrpc--deferred-actions connection)))) (id (or old-id (cl-incf (jsonrpc--next-request-id connection)))) - (make-timer - (lambda ( ) + (maybe-timer + (lambda () (when timeout - (run-with-timer - timeout nil - (lambda () - (jsonrpc--remove connection id (list deferred buf)) - (if timeout-fn (funcall timeout-fn) - (jsonrpc--debug - connection `(:timed-out ,method :id ,id - :params ,params))))))))) + (or timer + (setq + timer + (run-with-timer + timeout nil + (lambda () + (jsonrpc--remove connection id (list deferred buf)) + (if timeout-fn (funcall timeout-fn) + (jsonrpc--debug + connection `(:timed-out ,method :id ,id + :params ,params))))))))))) (when deferred (if (jsonrpc-connection-ready-p connection deferred) ;; Server is ready, we jump below and send it immediately. @@ -720,34 +776,39 @@ jsonrpc--async-request-1 (when (buffer-live-p buf) (with-current-buffer buf (save-excursion (goto-char point) - (apply #'jsonrpc-async-request + (apply #'jsonrpc--async-request-1 connection method params args))))) - (or timer (setq timer (funcall make-timer))) id) + (funcall maybe-timer) id) (jsonrpc--deferred-actions connection)) (cl-return-from jsonrpc--async-request-1 (list id timer)))) - ;; Really send it + ;; Really send it thru the wire ;; (jsonrpc-connection-send connection :id id :method method :params params) - (push (cons id - (list (or success-fn - (lambda (&rest _ignored) - (jsonrpc--debug - connection (list :message "success ignored" - :id id)))) - (or error-fn - (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--debug - connection (list - :message - (format "error ignored, status set (%s)" - message) - :id id :error code)))) - (setq timer (funcall make-timer)))) - (jsonrpc--request-continuations connection)) + ;; Setup some control structures + ;; + (when sync-request + (push (list id) (jsonrpc--sync-request-alist connection))) + + (jsonrpc--schedule connection + id + (or success-fn + (lambda (&rest _ignored) + (jsonrpc--debug + connection (list :message "success ignored" + :id id)))) + (or error-fn + (jsonrpc-lambda (&key code message &allow-other-keys) + (jsonrpc--debug + connection (list + :message + (format "error ignored, status set (%s)" + message) + :id id :error code)))) + (funcall maybe-timer)) (list id timer))) (defun jsonrpc--message (format &rest args) commit 222f563f136c5cb106df1fb94c177fe24c83683f Author: João Távora Date: Wed Dec 20 10:28:52 2023 -0600 Jsonrpc: rework implementation of continuations Preparatory work for fix of bug#67945 * lisp/jsonrpc.el (jsonrpc-connection): Change slots. (jsonrpc--remove): New helper (jsonrpc-forget-pending-continuations) (jsonrpc-connection-receive) (jsonrpc-request) (jsonrpc--process-sentinel) (jsonrpc--async-request-1) (jsonrpc--async-request-1): Rework. (jsonrpc-continuation-count): New convenience helper. * lisp/progmodes/eglot.el (eglot--mode-line-format): Stop using jsonrpc--request-continuations. diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index f5db3674366..936b17929ec 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -69,9 +69,9 @@ jsonrpc-connection :accessor jsonrpc-last-error :documentation "Last JSONRPC error message received from endpoint.") (-request-continuations - :initform (make-hash-table) + :initform nil :accessor jsonrpc--request-continuations - :documentation "A hash table of request ID to continuation lambdas.") + :documentation "An alist of request IDs to continuation lambdas.") (-events-buffer :initform nil :accessor jsonrpc--events-buffer @@ -187,7 +187,7 @@ jsonrpc-events-buffer (defun jsonrpc-forget-pending-continuations (connection) "Stop waiting for responses from the current JSONRPC CONNECTION." - (clrhash (jsonrpc--request-continuations connection))) + (setf (jsonrpc--request-continuations connection) nil)) (defvar jsonrpc-inhibit-debug-on-error nil "Inhibit `debug-on-error' when answering requests. @@ -207,7 +207,7 @@ jsonrpc-connection-receive (cond ((and method id) 'request) (method 'notification) (id 'reply))) - (let (continuations) + (let (triplet) (setf (jsonrpc-last-error connection) error) (cond (;; A remote request @@ -234,13 +234,9 @@ jsonrpc-connection-receive (funcall (jsonrpc--notification-dispatcher connection) connection (intern method) params)) (;; A remote response - (setq continuations - (and id (gethash id (jsonrpc--request-continuations connection)))) - (let ((timer (nth 2 continuations))) - (when timer (cancel-timer timer))) - (remhash id (jsonrpc--request-continuations connection)) - (if error (funcall (nth 1 continuations) error) - (funcall (nth 0 continuations) result)))) + (setq triplet (and id (cdr (jsonrpc--remove connection id)))) + (if error (funcall (nth 1 triplet) error) + (funcall (nth 0 triplet) result)))) (jsonrpc--call-deferred connection)))) @@ -360,11 +356,8 @@ jsonrpc-request ;; timeout function and response filter, but we still have ;; to protect against user-quit (C-g) or the ;; `cancel-on-input' case. - (pcase-let* ((`(,id ,timer) id-and-timer)) - (remhash id (jsonrpc--request-continuations connection)) - (remhash (list deferred (current-buffer)) - (jsonrpc--deferred-actions connection)) - (when timer (cancel-timer timer)))))) + (pcase-let* ((`(,id ,_) id-and-timer)) + (jsonrpc--remove connection id (list deferred (current-buffer))))))) (when (eq 'error (car retval)) (signal 'jsonrpc-error (cons @@ -577,14 +570,14 @@ jsonrpc--process-sentinel (let ((inhibit-read-only t)) (insert "\n----------b---y---e---b---y---e----------\n"))) ;; Cancel outstanding timers - (maphash (lambda (_id triplet) - (pcase-let ((`(,_success ,_error ,timeout) triplet)) - (when timeout (cancel-timer timeout)))) - (jsonrpc--request-continuations connection)) + (mapc (lambda (_id &rest triplet) + (pcase-let ((`(,_success ,_error ,timeout) triplet)) + (when timeout (cancel-timer timeout)))) + (jsonrpc--request-continuations connection)) (process-put proc 'jsonrpc-sentinel-cleanup-started t) (unwind-protect ;; Call all outstanding error handlers - (maphash (lambda (_id triplet) + (mapc (lambda (_id &rest triplet) (pcase-let ((`(,_success ,error ,_timeout) triplet)) (funcall error '(:code -1 :message "Server died")))) (jsonrpc--request-continuations connection)) @@ -675,6 +668,17 @@ jsonrpc--process-filter (jsonrpc-connection-receive conn m))) msg))))))) +(defun jsonrpc--remove (conn id &optional deferred-spec) + "Cancel CONN's continuations for ID, including its timer, if it exists. +Also cancel \"deferred actions\" if DEFERRED-SPEC. +Return the full continuation (ID SUCCESS-FN ERROR-FN TIMER)" + (with-slots ((conts -request-continuations) (defs -deferred-actions)) conn + (if deferred-spec (remhash deferred-spec defs)) + (when-let ((ass (assq id conts))) + (cancel-timer (elt (cdr ass) 2)) + (setf conts (delete ass conts)) + ass))) + (cl-defun jsonrpc--async-request-1 (connection method params @@ -698,9 +702,7 @@ jsonrpc--async-request-1 (run-with-timer timeout nil (lambda () - (remhash id (jsonrpc--request-continuations connection)) - (remhash (list deferred buf) - (jsonrpc--deferred-actions connection)) + (jsonrpc--remove connection id (list deferred buf)) (if timeout-fn (funcall timeout-fn) (jsonrpc--debug connection `(:timed-out ,method :id ,id @@ -730,22 +732,22 @@ jsonrpc--async-request-1 :id id :method method :params params) - (puthash id - (list (or success-fn - (lambda (&rest _ignored) - (jsonrpc--debug - connection (list :message "success ignored" - :id id)))) - (or error-fn - (jsonrpc-lambda (&key code message &allow-other-keys) - (jsonrpc--debug - connection (list - :message - (format "error ignored, status set (%s)" - message) - :id id :error code)))) - (setq timer (funcall make-timer))) - (jsonrpc--request-continuations connection)) + (push (cons id + (list (or success-fn + (lambda (&rest _ignored) + (jsonrpc--debug + connection (list :message "success ignored" + :id id)))) + (or error-fn + (jsonrpc-lambda (&key code message &allow-other-keys) + (jsonrpc--debug + connection (list + :message + (format "error ignored, status set (%s)" + message) + :id id :error code)))) + (setq timer (funcall make-timer)))) + (jsonrpc--request-continuations connection)) (list id timer))) (defun jsonrpc--message (format &rest args) @@ -905,6 +907,9 @@ jsonrpc-autoport-bootstrap (when np (delete-process np)) (error "[jsonrpc] Could not start and/or connect"))))))) +(defun jsonrpc-continuation-count (conn) + "Number of outstanding continuations for CONN." + (length (jsonrpc--request-continuations conn))) (provide 'jsonrpc) ;;; jsonrpc.el ends here diff --git a/lisp/progmodes/eglot.el b/lisp/progmodes/eglot.el index 6e43cc2b01c..2a3c2201e21 100644 --- a/lisp/progmodes/eglot.el +++ b/lisp/progmodes/eglot.el @@ -2136,8 +2136,7 @@ eglot--mode-line-format "Compose Eglot's mode-line." (let* ((server (eglot-current-server)) (nick (and server (eglot-project-nickname server))) - (pending (and server (hash-table-count - (jsonrpc--request-continuations server)))) + (pending (and server (jsonrpc-continuation-count server))) (last-error (and server (jsonrpc-last-error server)))) (append `(,(propertize commit 018cf86605b0ab1976c01ed5f1b511280c31887d Author: João Távora Date: Wed Dec 20 12:11:53 2023 -0600 trace.el: use cl-print Any non-trivial EIEO object in particular is impossible to read in the *trace-output* buffer without this. Functions, hash-tables, etc now print as they do in backtrace buffers. * lisp/emacs-lisp/trace.el (cl-print): Require it (trace-entry-message, trace-exit-message): Use cl-prin1-to-string diff --git a/lisp/emacs-lisp/trace.el b/lisp/emacs-lisp/trace.el index d802648d8ab..3881fe66eb4 100644 --- a/lisp/emacs-lisp/trace.el +++ b/lisp/emacs-lisp/trace.el @@ -128,6 +128,8 @@ ;;; Code: +(require 'cl-print) + (defgroup trace nil "Tracing facility for Emacs Lisp functions." :prefix "trace-" @@ -168,13 +170,13 @@ trace-entry-message some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d -> %S%s\n" + (format "%s%s%d -> %s%s\n" (mapconcat #'char-to-string (make-string (max 0 (1- level)) ?|) " ") (if (> level 1) " " "") level ;; FIXME: Make it so we can click the function name to jump to its ;; definition and/or untrace it. - (cons function args) + (cl-prin1-to-string (cons function args)) context))) (defun trace-exit-message (function level value context) @@ -184,13 +186,13 @@ trace-exit-message some global variables)." (let ((print-circle t) (print-escape-newlines t)) - (format "%s%s%d <- %s: %S%s\n" + (format "%s%s%d <- %s: %s%s\n" (mapconcat 'char-to-string (make-string (1- level) ?|) " ") (if (> level 1) " " "") level function ;; Do this so we'll see strings: - value + (cl-prin1-to-string value) context))) (defvar trace--timer nil) commit 62bf0b7a571fd8ccf179d2594adf9b61727a7aea Merge: 7275cecdf95 6cc1418fc3e Author: Stefan Monnier Date: Wed Dec 20 18:34:57 2023 -0500 Merge commit 'new-fix-for-bug-60819' commit 7275cecdf95d805adc4676462f2d924883be0047 Author: Stefan Monnier Date: Wed Dec 20 17:50:48 2023 -0500 * lisp/cedet/semantic/db.el (semanticdb-create-database): Remove obsolete arg diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 319d1d1b91c..b2f9c1bd52d 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -408,6 +408,7 @@ seconds-to-string "Formatting used by the function `seconds-to-string'.") ;;;###autoload (defun seconds-to-string (delay) + ;; FIXME: There's a similar (tho fancier) function in mastodon.el! "Convert the time interval in seconds to a short string." (cond ((> 0 delay) (concat "-" (seconds-to-string (- delay)))) ((= 0 delay) "0s") diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index 0c78493542f..e8c008cb8c6 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -393,9 +393,7 @@ semanticdb-create-database If DIRECTORY doesn't exist, create a new one." (let ((db (semanticdb-directory-loaded-p directory))) (unless db - (setq db (semanticdb-project-database - (file-name-nondirectory directory) - :tables nil)) + (setq db (semanticdb-project-database :tables nil)) ;; Set this up here. We can't put it in the constructor because it ;; would be saved, and we want DB files to be portable. (setf (slot-value db 'reference-directory) (file-truename directory))) commit 40dafa9af0ae3b1826409ebed80cb65f56591ffb Author: Stefan Monnier Date: Wed Dec 20 17:50:09 2023 -0500 * lisp/org/org-src.el (org-src-font-lock-fontify-block): Fix point-min /= 1 diff --git a/lisp/org/org-src.el b/lisp/org/org-src.el index aadd8eba579..941399e15a5 100644 --- a/lisp/org/org-src.el +++ b/lisp/org/org-src.el @@ -658,7 +658,9 @@ org-src-font-lock-fontify-block (when new-prop (if (not (eq prop 'invisible)) (put-text-property - (+ start (1- pos)) (1- (+ start next)) prop new-prop + (+ start (- pos (point-min))) + (+ start (- next (point-min))) + prop new-prop org-buffer) ;; Special case. `invisible' text property may ;; clash with Org folding. Do not assign @@ -690,7 +692,8 @@ org-src-font-lock-fontify-block (when invisibility-spec (add-to-invisibility-spec invisibility-spec)) (put-text-property - (+ start (1- pos)) (1- (+ start next)) + (+ start (- pos (point-min))) + (+ start (- next (point-min))) 'org-src-invisible new-prop org-buffer))))))) (setq pos next))) commit c9021c62f287c3fe0f9d7ea216a6f1da10e36e72 Author: Stefan Monnier Date: Wed Dec 20 17:49:21 2023 -0500 (bibtex-font-lock-keywords): Expose a lambda to the compiler Also use #' to quote function names. * lisp/textmodes/bibtex.el (bibtex-font-lock-keywords): Expose a lambda to the compiler. diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 32d2786b86c..85beb3ca897 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -1837,7 +1837,7 @@ bibtex-font-lock-keywords (bibtex-font-lock-url) (bibtex-font-lock-crossref) ;; cite ,@(mapcar (lambda (matcher) - `((lambda (bound) (bibtex-font-lock-cite ',matcher bound)))) + `(,(lambda (bound) (bibtex-font-lock-cite matcher bound)))) bibtex-cite-matcher-alist)) "Default expressions to highlight in BibTeX mode.") @@ -2760,7 +2760,7 @@ bibtex-format-entry (setq error-field-name (car (last (aref alt-fields idx)))) (user-error "Alternative mandatory fields `%s' are missing" - (mapconcat 'identity + (mapconcat #'identity (reverse (aref alt-expect idx)) ", "))) @@ -2768,7 +2768,7 @@ bibtex-format-entry (setq error-field-name (car (last (aref alt-fields idx)))) (user-error "Fields `%s' are alternatives" - (mapconcat 'identity + (mapconcat #'identity (reverse (aref alt-fields idx)) ", "))))))) @@ -3624,7 +3624,7 @@ bibtex-mode (unless bibtex-parse-idle-timer (setq bibtex-parse-idle-timer (run-with-idle-timer bibtex-parse-keys-timeout t - 'bibtex-parse-buffers-stealthily))) + #'bibtex-parse-buffers-stealthily))) (setq-local paragraph-start "[ \f\n\t]*$") (setq-local comment-column 0) (setq-local defun-prompt-regexp "^[ \t]*@[[:alnum:]]+[ \t]*") @@ -3829,7 +3829,7 @@ bibtex--skip-field-aliases (if (and (nth 3 elt) (<= 0 (nth 3 elt))) (push (nth 3 elt) alt-list))) - (setq alt-list (sort alt-list '<)) + (setq alt-list (sort alt-list #'<)) ;; Skip aliases. If ELT is marked as "proper alternative", but all ;; alternatives for field ELT are aliases, we do not label ELT ;; as an alternative either. @@ -4641,7 +4641,7 @@ bibtex-validate (let ((file (file-name-nondirectory (buffer-file-name))) (dir default-directory) (err-buf "*BibTeX validation errors*")) - (setq error-list (sort error-list 'car-less-than-car)) + (setq error-list (sort error-list #'car-less-than-car)) (with-current-buffer (get-buffer-create err-buf) (setq default-directory dir) (unless (eq major-mode 'compilation-mode) (compilation-mode)) @@ -4714,7 +4714,7 @@ bibtex-validate-globally (delete-region (point-min) (point-max)) (insert (substitute-command-keys "BibTeX mode command `bibtex-validate-globally'\n\n")) - (dolist (err (sort error-list 'string-lessp)) (insert err)) + (dolist (err (sort error-list #'string-lessp)) (insert err)) (set-buffer-modified-p nil)) (goto-char (point-min)) (forward-line 2)) ; first error message commit b088cf025b58e6b6a38d7eee910a887437c4f275 Author: Matto Fransen Date: Tue Dec 19 13:14:33 2023 +0100 Specific rcirc log file time stamp format The time stamp format in the chat buffer may now differ from the format in the log files. * doc/misc/rcirc.texi: Document new variable * lisp/net/rcirc.el (rcirc-log-time-format): Custom variable for the format. (bug#67597) Copyright-paperwork-exempt: yes diff --git a/doc/misc/rcirc.texi b/doc/misc/rcirc.texi index 6b10d1ab2a4..d89d3824415 100644 --- a/doc/misc/rcirc.texi +++ b/doc/misc/rcirc.texi @@ -929,6 +929,7 @@ Changing the time stamp format @cindex date time @cindex format time stamp @vindex rcirc-time-format +@vindex rcirc-log-time-format @code{rcirc-time-format} is the format used for the time stamp. Here's how to include the date in the time stamp: @@ -937,6 +938,9 @@ Changing the time stamp format (setopt rcirc-time-format "%Y-%m-%d %H:%M ") @end example +For log files, a different time format can be specified using the +@code{rcirc-log-time-format} user option. + @findex rcirc-when If you don't wish to use verbose time formatting all the time, you can use the @code{rcirc-when} command to display a complete timestamp for diff --git a/etc/NEWS b/etc/NEWS index 90ff23b7937..f96f06af0e2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1153,6 +1153,11 @@ URIs are now prefixed with "https://" instead. Now, calling '(thing-at-point 'url)' when point is on a bug reference will return the URL for that bug. ++++ +*** New user option 'rcirc-log-time-format' +This allows for rcirc logs to use a custom timestamp format, than the +chat buffers use by default. + ** Customize +++ diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index ecfeb9f8f84..6390d4dd284 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -229,6 +229,12 @@ rcirc-time-format Used as the first arg to `format-time-string'." :type 'string) +(defcustom rcirc-log-time-format "%d-%b %H:%M " + "Describes how timestamps are printed in the log files. +Used as the first arg to `format-time-string'." + :version "30.1" + :type 'string ) + (defcustom rcirc-input-ring-size 1024 "Size of input history ring." :type 'integer) @@ -2209,7 +2215,7 @@ rcirc-log (parse-iso8601-time-string time t)))) (unless (null filename) (let ((cell (assoc-string filename rcirc-log-alist)) - (line (concat (format-time-string rcirc-time-format time) + (line (concat (format-time-string rcirc-log-time-format time) (substring-no-properties (rcirc-format-response-string process sender response target text)) commit 2e5d50ee43096ff5422c88f835ccceb1728def06 Author: Thierry Volpiatto Date: Wed Dec 20 18:08:03 2023 +0100 Rename *basic symbols and words to traditional in register * lisp/register.el (register-use-preview): Do it. (register-read-with-preview-traditional): Renamed from register-read-with-preview-basic. diff --git a/lisp/register.el b/lisp/register.el index c2b10a91adb..c5abcf45109 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -123,30 +123,30 @@ register-preview-function The function should return a string, the description of the argument. It is set according to the value of `register--read-with-preview-function'.") -(defcustom register-use-preview 'basic +(defcustom register-use-preview 'traditional "Maybe show register preview. This has no effect when `register--read-with-preview-function' value -is `register-read-with-preview-basic'. +is `register-read-with-preview-traditional'. When set to `t' show a preview buffer with navigation and highlighting. -When nil show a basic preview buffer and exit minibuffer +When nil show a preview buffer with no such features and exit minibuffer immediately after insertion in minibuffer. When set to \\='never behave as above but with no preview buffer at -all. -When set to \\='basic provide a much more basic preview according to +all but the preview buffer is still accessible with `help-char' (C-h). +When set to \\='traditional provide a much more basic preview according to `register-preview-delay', it has the exact same behavior as in Emacs-29." :type '(choice (const :tag "Use preview" t) (const :tag "Use quick preview" nil) (const :tag "Never use preview" never) - (const :tag "Basic preview like Emacs-29" basic)) + (const :tag "Basic preview like Emacs-29" traditional)) :version 30.1 :set (lambda (var val) (set var val) (setq register--read-with-preview-function - (if (eq val 'basic) - #'register-read-with-preview-basic + (if (eq val 'traditional) + #'register-read-with-preview-traditional #'register-read-with-preview-fancy)) (setq register-preview-function nil))) @@ -185,7 +185,7 @@ register--preview-function "Returns a function to format a register for previewing. This according to the value of READ-PREVIEW-FUNCTION.") (cl-defmethod register--preview-function ((_read-preview-function - (eql register-read-with-preview-basic))) + (eql register-read-with-preview-traditional))) #'register-preview-default) (cl-defmethod register--preview-function ((_read-preview-function (eql register-read-with-preview-fancy))) @@ -433,7 +433,7 @@ register-read-with-preview display such a window regardless." (funcall register--read-with-preview-function prompt)) -(defun register-read-with-preview-basic (prompt) +(defun register-read-with-preview-traditional (prompt) "Read and return a register name, possibly showing existing registers. Prompt with the string PROMPT. If `register-alist' and `register-preview-delay' are both non-nil, display a window commit b499d4f65a7c1ce45500dcbf1c5c63d85241b330 Author: Thierry Volpiatto Date: Tue Dec 19 17:45:22 2023 +0100 Fix condition in register-read-with-preview-fancy Now with have :noconfirm no need to check for '(set modify) otherwise we fail as well in kmacros when register-use-preview is t. The conditions should not be hard coded in register-read-with-preview-fancy but in the cl-defmethod register-command-info for each command. * lisp/register.el (register-read-with-preview-fancy): Remove now unneeded condition. diff --git a/lisp/register.el b/lisp/register.el index 19b207960d6..c2b10a91adb 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -207,14 +207,16 @@ register-command-info :types '(string number) :msg "Insert register `%s'" :act 'insert - :smatch t)) + :smatch t + :noconfirm (memq register-use-preview '(nil never)))) (cl-defmethod register-command-info ((_command (eql jump-to-register))) (make-register-preview-info :types '(window frame marker kmacro file buffer file-query) :msg "Jump to register `%s'" :act 'jump - :smatch t)) + :smatch t + :noconfirm (memq register-use-preview '(nil never)))) (cl-defmethod register-command-info ((_command (eql view-register))) (make-register-preview-info :types '(all) @@ -555,12 +557,10 @@ register-read-with-preview-fancy (unless (string= pat "") (with-selected-window (minibuffer-window) (if (and (member pat strs) - (memq act '(set modify)) (null noconfirm)) (with-selected-window (minibuffer-window) (minibuffer-message msg pat)) - ;; The action is insert or - ;; jump or noconfirm is specifed + ;; :noconfirm is specifed ;; explicitely, don't ask for ;; confirmation and exit immediately (bug#66394). (setq result pat) commit 73acd543cb1f88af880445de1e1a7238dd46c9de Author: Stefan Monnier Date: Mon Dec 18 07:11:42 2023 +0100 Fix issue with register commands in kmacro Using post-command-hook in minibuffer-setup-hook instead of a timer allow running exit-minibuffer without delay and ensure the serie of commands used in a kmacro run synchronously. * lisp/register.el (register-read-with-preview-fancy): Do it. diff --git a/lisp/register.el b/lisp/register.el index 8f0c6a7105d..19b207960d6 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -478,7 +478,7 @@ register-read-with-preview-fancy m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types msg result timer act win strs smatch noconfirm) + types msg result act win strs smatch noconfirm) (if data (setq types (register-preview-info-types data) msg (register-preview-info-msg data) @@ -511,68 +511,66 @@ register-read-with-preview-fancy (progn (minibuffer-with-setup-hook (lambda () - (setq timer - (run-with-idle-timer - 0.01 'repeat - (lambda () - (with-selected-window (minibuffer-window) - (let ((input (minibuffer-contents))) - (when (> (length input) 1) - (let ((new (substring input 1)) - (old (substring input 0 1))) - (setq input (if (or (null smatch) - (member new strs)) - new old)) - (delete-minibuffer-contents) - (insert input))) - (when (and smatch (not (string= input "")) - (not (member input strs))) - (setq input "") - (delete-minibuffer-contents) - (minibuffer-message "Not matching")) - (when (not (string= input pat)) - (setq pat input)))) - (if (setq win (get-buffer-window buffer)) - (with-selected-window win - (let ((ov (make-overlay - (point-min) (point-min))) - ;; Allow upper-case and - ;; lower-case letters to refer - ;; to different registers. - (case-fold-search nil)) - (goto-char (point-min)) - (remove-overlays) - (unless (string= pat "") - (if (re-search-forward (concat "^" pat) nil t) - (progn (move-overlay - ov - (match-beginning 0) (pos-eol)) - (overlay-put ov 'face 'match) - (when msg - (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)))) - (with-selected-window (minibuffer-window) - (minibuffer-message - "Register `%s' is empty" pat)))))) - (unless (string= pat "") - (with-selected-window (minibuffer-window) - (if (and (member pat strs) - (memq act '(set modify)) - (null noconfirm)) - (with-selected-window (minibuffer-window) - (minibuffer-message msg pat)) - ;; The action is insert or - ;; jump or noconfirm is specifed - ;; explicitely, don't ask for - ;; confirmation and exit immediately (bug#66394). - (setq result pat) - (exit-minibuffer))))))))) + (add-hook 'post-command-hook + (lambda () + (with-selected-window (minibuffer-window) + (let ((input (minibuffer-contents))) + (when (> (length input) 1) + (let ((new (substring input 1)) + (old (substring input 0 1))) + (setq input (if (or (null smatch) + (member new strs)) + new old)) + (delete-minibuffer-contents) + (insert input))) + (when (and smatch (not (string= input "")) + (not (member input strs))) + (setq input "") + (delete-minibuffer-contents) + (minibuffer-message "Not matching")) + (when (not (string= input pat)) + (setq pat input)))) + (if (setq win (get-buffer-window buffer)) + (with-selected-window win + (let ((ov (make-overlay + (point-min) (point-min))) + ;; Allow upper-case and + ;; lower-case letters to refer + ;; to different registers. + (case-fold-search nil)) + (goto-char (point-min)) + (remove-overlays) + (unless (string= pat "") + (if (re-search-forward (concat "^" pat) nil t) + (progn (move-overlay + ov + (match-beginning 0) (pos-eol)) + (overlay-put ov 'face 'match) + (when msg + (with-selected-window (minibuffer-window) + (minibuffer-message msg pat)))) + (with-selected-window (minibuffer-window) + (minibuffer-message + "Register `%s' is empty" pat)))))) + (unless (string= pat "") + (with-selected-window (minibuffer-window) + (if (and (member pat strs) + (memq act '(set modify)) + (null noconfirm)) + (with-selected-window (minibuffer-window) + (minibuffer-message msg pat)) + ;; The action is insert or + ;; jump or noconfirm is specifed + ;; explicitely, don't ask for + ;; confirmation and exit immediately (bug#66394). + (setq result pat) + (exit-minibuffer)))))) + nil 'local)) (setq result (read-from-minibuffer prompt nil map nil nil (register-preview-get-defaults act)))) (cl-assert (and result (not (string= result ""))) nil "No register specified") (string-to-char result)) - (when timer (cancel-timer timer)) (let ((w (get-buffer-window buf))) (and (window-live-p w) (delete-window w))) (and (get-buffer buf) (kill-buffer buf))))) commit 67e16d37e9c83fea9f67d144eeac27a83d52c949 Author: Thierry Volpiatto Date: Tue Dec 12 07:24:32 2023 +0100 Provide emacs-29 behavior for register-preview It is now the default with a value of register-use-preview eq to basic. To change this one have now to customize register-use-preview to another value. * lisp/register.el (register-preview-delay): Remove obsolescence. (register--read-with-preview-function): New. (register-use-preview): New option basic, it is now the default. (register-preview-default-1): New the register-preview-default used by `register-read-with-preview-fancy`. (register-preview-default): Restored (same as Emacs-29). (register--preview-function): Generic fn that return the right function for register--preview-function. (register-preview): Restored (same behavior as Emacs-29). (register-preview-1): Used by `register-read-with-preview-fancy'. (register-read-with-preview-basic): The old register-read-with-preview. (register-read-with-preview-fancy): The new register-read-with-preview. diff --git a/lisp/register.el b/lisp/register.el index cd6f2861315..8f0c6a7105d 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -100,25 +100,55 @@ register-preview-delay :version "24.4" :type '(choice number (const :tag "No preview unless requested" nil)) :group 'register) -(make-obsolete-variable 'register-preview-delay "No longer used." "30.1") (defcustom register-preview-default-keys (mapcar #'string (number-sequence ?a ?z)) "Default keys for setting a new register." - :type '(repeat string)) - -(defcustom register-use-preview t - "Whether to show preview of registers. - -If the value is t, show a preview buffer with navigation and highlighting. -If the value is nil, show a basic preview buffer and exit minibuffer -immediately after the register name is inserted into minibuffer. -If the value is \\='never, behave as for nil, but with no preview buffer -at all." + :type '(repeat string) + :version 30.1) + +(defvar register--read-with-preview-function nil + "The register read preview function to use. +Two functions are provided, one that provide navigation and +highlighting of the register selected, filtering of register +according to command in use, defaults register to use when +setting a new register, confirmation and notification when you +are about to overwrite a register and generic functions to +configure how each existing commands behave. The other function +provided is the same as what was used in Emacs-29, no filtering, +no navigation, no defaults.") + +(defvar register-preview-function nil + "Function to format a register for previewing. +Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'. +The function should return a string, the description of the argument. +It is set according to the value of `register--read-with-preview-function'.") + +(defcustom register-use-preview 'basic + "Maybe show register preview. + +This has no effect when `register--read-with-preview-function' value +is `register-read-with-preview-basic'. + +When set to `t' show a preview buffer with navigation and highlighting. +When nil show a basic preview buffer and exit minibuffer +immediately after insertion in minibuffer. +When set to \\='never behave as above but with no preview buffer at +all. +When set to \\='basic provide a much more basic preview according to +`register-preview-delay', it has the exact same behavior as in Emacs-29." :type '(choice (const :tag "Use preview" t) (const :tag "Use quick preview" nil) - (const :tag "Never use preview" never)) - :version "30.1") + (const :tag "Never use preview" never) + (const :tag "Basic preview like Emacs-29" basic)) + :version 30.1 + :set (lambda (var val) + (set var val) + (setq register--read-with-preview-function + (if (eq val 'basic) + #'register-read-with-preview-basic + #'register-read-with-preview-fancy)) + (setq register-preview-function nil))) (defun get-register (register) "Return contents of Emacs register named REGISTER, or nil if none." @@ -138,17 +168,28 @@ register-describe-oneline (substring d (match-end 0)) d))) -(defun register-preview-default (r) +(defun register-preview-default-1 (r) "Function that is the default value of the variable `register-preview-function'." (format "%s: %s\n" (propertize (string (car r)) 'display (single-key-description (car r))) (register-describe-oneline (car r)))) -(defvar register-preview-function #'register-preview-default - "Function to format a register for previewing. -Called with one argument, a cons (NAME . CONTENTS) as found in `register-alist'. -The function should return a string, the description of the argument.") +(defun register-preview-default (r) + "Function that is the default value of the variable `register-preview-function'." + (format "%s: %s\n" + (single-key-description (car r)) + (register-describe-oneline (car r)))) + +(cl-defgeneric register--preview-function (read-preview-function) + "Returns a function to format a register for previewing. +This according to the value of READ-PREVIEW-FUNCTION.") +(cl-defmethod register--preview-function ((_read-preview-function + (eql register-read-with-preview-basic))) + #'register-preview-default) +(cl-defmethod register--preview-function ((_read-preview-function + (eql register-read-with-preview-fancy))) + #'register-preview-default-1) (cl-defstruct register-preview-info "Store data for a specific register command. @@ -310,9 +351,9 @@ register--type (cl-defmethod register--type ((_regval string)) 'string) (cl-defmethod register--type ((_regval number)) 'number) (cl-defmethod register--type ((_regval marker)) 'marker) -(cl-defmethod register--type ((_regval (eql 'buffer))) 'buffer) -(cl-defmethod register--type ((_regval (eql 'file))) 'file) -(cl-defmethod register--type ((_regval (eql 'file-query))) 'file-query) +(cl-defmethod register--type ((_regval (eql buffer))) 'buffer) +(cl-defmethod register--type ((_regval (eql file))) 'file) +(cl-defmethod register--type ((_regval (eql file-query))) 'file-query) (cl-defmethod register--type ((_regval window-configuration)) 'window) (cl-deftype frame-register () '(satisfies frameset-register-p)) (cl-defmethod register--type :extra "frame-register" (_regval) 'frame) @@ -327,12 +368,39 @@ register-of-type-alist when (memq (register-type register) types) collect register))) -(defun register-preview (buffer &optional show-empty types) +(defun register-preview (buffer &optional show-empty) "Pop up a window showing the registers preview in BUFFER. If SHOW-EMPTY is non-nil, show the window even if no registers. +Format of each entry is controlled by the variable `register-preview-function'." + (unless register-preview-function + (setq register-preview-function (register--preview-function + register--read-with-preview-function))) + (when (or show-empty (consp register-alist)) + (with-current-buffer-window + buffer + (cons 'display-buffer-below-selected + '((window-height . fit-window-to-buffer) + (preserve-size . (nil . t)))) + nil + (with-current-buffer standard-output + (setq cursor-in-non-selected-windows nil) + (mapc (lambda (elem) + (when (get-register (car elem)) + (insert (funcall register-preview-function elem)))) + register-alist))))) + +(defun register-preview-1 (buffer &optional show-empty types) + "Pop up a window showing the registers preview in BUFFER. + +This is the preview function use with +`register-read-with-preview-fancy' function. +If SHOW-EMPTY is non-nil, show the window even if no registers. Argument TYPES (a list) specify the types of register to show, when nil show all registers, see `register-type' for suitable types. Format of each entry is controlled by the variable `register-preview-function'." + (unless register-preview-function + (setq register-preview-function (register--preview-function + register--read-with-preview-function))) (let ((registers (register-of-type-alist (or types '(all))))) (when (or show-empty (consp registers)) (with-current-buffer-window @@ -360,6 +428,46 @@ register-read-with-preview "Read and return a register name, possibly showing existing registers. Prompt with the string PROMPT. If `help-char' (or a member of `help-event-list') is pressed, +display such a window regardless." + (funcall register--read-with-preview-function prompt)) + +(defun register-read-with-preview-basic (prompt) + "Read and return a register name, possibly showing existing registers. +Prompt with the string PROMPT. If `register-alist' and +`register-preview-delay' are both non-nil, display a window +listing existing registers after `register-preview-delay' seconds. +If `help-char' (or a member of `help-event-list') is pressed, +display such a window regardless." + (let* ((buffer "*Register Preview*") + (timer (when (numberp register-preview-delay) + (run-with-timer register-preview-delay nil + (lambda () + (unless (get-buffer-window buffer) + (register-preview buffer)))))) + (help-chars (cl-loop for c in (cons help-char help-event-list) + when (not (get-register c)) + collect c))) + (unwind-protect + (progn + (while (memq (read-key (propertize prompt 'face 'minibuffer-prompt)) + help-chars) + (unless (get-buffer-window buffer) + (register-preview buffer 'show-empty))) + (when (or (eq ?\C-g last-input-event) + (eq 'escape last-input-event) + (eq ?\C-\[ last-input-event)) + (keyboard-quit)) + (if (characterp last-input-event) last-input-event + (error "Non-character input-event"))) + (and (timerp timer) (cancel-timer timer)) + (let ((w (get-buffer-window buffer))) + (and (window-live-p w) (delete-window w))) + (and (get-buffer buffer) (kill-buffer buffer))))) + +(defun register-read-with-preview-fancy (prompt) + "Read and return a register name, possibly showing existing registers. +Prompt with the string PROMPT. +If `help-char' (or a member of `help-event-list') is pressed, display such a window regardless." (let* ((buffer "*Register Preview*") (buffer1 "*Register quick preview*") @@ -392,13 +500,13 @@ register-read-with-preview ;; Do nothing when buffer1 is in use. (unless (get-buffer-window buf) (with-selected-window (minibuffer-selected-window) - (register-preview buffer 'show-empty types)))))) + (register-preview-1 buffer 'show-empty types)))))) (define-key map (kbd "") 'register-preview-next) (define-key map (kbd "") 'register-preview-previous) (define-key map (kbd "C-n") 'register-preview-next) (define-key map (kbd "C-p") 'register-preview-previous) (unless (or executing-kbd-macro (eq register-use-preview 'never)) - (register-preview buf nil types)) + (register-preview-1 buf nil types)) (unwind-protect (progn (minibuffer-with-setup-hook commit 46367e0a5c9a58087d59f19966b23ee980bdbb24 Author: Thierry Volpiatto Date: Mon Dec 11 07:02:40 2023 +0100 Don't confirm with RET even when overwriting in register commands This happen when register-use-preview is nil or never. This reproduce what we had previously in 29.1 but with filtering in the preview and default registers are provided for the commands of type 'set'. This is implemented with cl-defmethod to keep the code as much as possible configurable. * lisp/register.el (register-preview-info): New slot. (register-command-info): Add new methods for copy-to-register, point-to-register, number-to-register, window-configuration-to-register, frameset-to-register and copy-rectangle-to-register. (register-read-with-preview): Bind noconfirm. diff --git a/lisp/register.el b/lisp/register.el index ef529cd67e5..cd6f2861315 100644 --- a/lisp/register.el +++ b/lisp/register.el @@ -156,7 +156,7 @@ register-preview-info MSG is the minibuffer message to send when a register is selected. ACT is the type of action the command is doing on register. SMATCH accept a boolean value to say if command accept non matching register." - types msg act smatch) + types msg act smatch noconfirm) (cl-defgeneric register-command-info (command) "Returns a `register-preview-info' object storing data for COMMAND." @@ -179,24 +179,66 @@ register-command-info :types '(all) :msg "View register `%s'" :act 'view + :noconfirm (memq register-use-preview '(nil never)) :smatch t)) (cl-defmethod register-command-info ((_command (eql append-to-register))) (make-register-preview-info :types '(string number) :msg "Append to register `%s'" :act 'modify + :noconfirm (memq register-use-preview '(nil never)) :smatch t)) (cl-defmethod register-command-info ((_command (eql prepend-to-register))) (make-register-preview-info :types '(string number) :msg "Prepend to register `%s'" :act 'modify + :noconfirm (memq register-use-preview '(nil never)) :smatch t)) (cl-defmethod register-command-info ((_command (eql increment-register))) (make-register-preview-info :types '(string number) :msg "Increment register `%s'" :act 'modify + :noconfirm (memq register-use-preview '(nil never)) + :smatch t)) +(cl-defmethod register-command-info ((_command (eql copy-to-register))) + (make-register-preview-info + :types '(all) + :msg "Copy to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info ((_command (eql point-to-register))) + (make-register-preview-info + :types '(all) + :msg "Point to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info ((_command (eql number-to-register))) + (make-register-preview-info + :types '(all) + :msg "Number to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info + ((_command (eql window-configuration-to-register))) + (make-register-preview-info + :types '(all) + :msg "Window configuration to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info ((_command (eql frameset-to-register))) + (make-register-preview-info + :types '(all) + :msg "Frameset to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)))) +(cl-defmethod register-command-info ((_command (eql copy-rectangle-to-register))) + (make-register-preview-info + :types '(all) + :msg "Copy rectangle to register `%s'" + :act 'set + :noconfirm (memq register-use-preview '(nil never)) :smatch t)) (defun register-preview-forward-line (arg) @@ -328,12 +370,13 @@ register-read-with-preview m)) (data (register-command-info this-command)) (enable-recursive-minibuffers t) - types msg result timer act win strs smatch) + types msg result timer act win strs smatch noconfirm) (if data - (setq types (register-preview-info-types data) - msg (register-preview-info-msg data) - act (register-preview-info-act data) - smatch (register-preview-info-smatch data)) + (setq types (register-preview-info-types data) + msg (register-preview-info-msg data) + act (register-preview-info-act data) + smatch (register-preview-info-smatch data) + noconfirm (register-preview-info-noconfirm data)) (setq types '(all) msg "Overwrite register `%s'" act 'set)) @@ -405,13 +448,15 @@ register-read-with-preview "Register `%s' is empty" pat)))))) (unless (string= pat "") (with-selected-window (minibuffer-window) - (if (and (member pat strs) (memq act '(set modify))) + (if (and (member pat strs) + (memq act '(set modify)) + (null noconfirm)) (with-selected-window (minibuffer-window) (minibuffer-message msg pat)) - ;; An empty register or an existing - ;; one but the action is insert or - ;; jump, don't ask for confirmation - ;; and exit immediately (bug#66394). + ;; The action is insert or + ;; jump or noconfirm is specifed + ;; explicitely, don't ask for + ;; confirmation and exit immediately (bug#66394). (setq result pat) (exit-minibuffer))))))))) (setq result (read-from-minibuffer commit 0d518b78d785613967fb1b375aa7932385991891 Author: Dmitry Gutov Date: Wed Dec 20 17:34:12 2023 +0200 project--read-file-cpd-relative: Don't abbreviate at all * lisp/progmodes/project.el (project--read-file-cpd-relative): Don't abbreviate at all, only suffixes are shown anyway. And expand-file-name is slightly faster. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index f7e307515de..0082f12666a 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1145,15 +1145,15 @@ project--read-file-cpd-relative (_ (when included-cpd (setq substrings (cons "./" substrings)))) (new-collection (project--file-completion-table substrings)) - (abbr-cpd (abbreviate-file-name common-parent-directory)) - (abbr-cpd-length (length abbr-cpd)) + (abs-cpd (expand-file-name common-parent-directory)) + (abs-cpd-length (length abs-cpd)) (relname (cl-letf (((symbol-value hist) (mapcan (lambda (s) - (setq s (abbreviate-file-name s)) - (and (string-prefix-p abbr-cpd s) - (not (eq abbr-cpd-length (length s))) - (list (substring s abbr-cpd-length)))) + (setq s (expand-file-name s)) + (and (string-prefix-p abs-cpd s) + (not (eq abs-cpd-length (length s))) + (list (substring s abs-cpd-length)))) (symbol-value hist)))) (project--completing-read-strict prompt new-collection commit 338409c1f19e1d3a97d12edaf5ac36f1a781d08a Author: Dmitry Gutov Date: Wed Dec 20 17:20:26 2023 +0200 Fix project-find-file history (with project--read-file-cpd-relative) * lisp/progmodes/project.el (project--transplant-file-name): Don't abbreviate here (bug#67901, bug#63829). (project--read-file-cpd-relative): Do it here instead. The reader functions should decide on the preferred format themselves. diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index 0fa623616b6..f7e307515de 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1110,10 +1110,9 @@ project-file-history-behavior (defun project--transplant-file-name (filename project) (when-let ((old-root (get-text-property 0 'project filename))) - (abbreviate-file-name - (expand-file-name - (file-relative-name filename old-root) - (project-root project))))) + (expand-file-name + (file-relative-name filename old-root) + (project-root project)))) (defun project--read-file-cpd-relative (prompt all-files &optional predicate @@ -1151,6 +1150,7 @@ project--read-file-cpd-relative (relname (cl-letf (((symbol-value hist) (mapcan (lambda (s) + (setq s (abbreviate-file-name s)) (and (string-prefix-p abbr-cpd s) (not (eq abbr-cpd-length (length s))) (list (substring s abbr-cpd-length)))) commit fe67c36cd9bb2967e0c2eca3d4a31c0950130eb7 Author: Stefan Monnier Date: Sat Dec 9 23:57:35 2023 -0500 (dired): Remove `ls-lisp` advice `ls-lisp` used to advise `dired` because `dired-insert-directory` blindly used `insert-directory-program` (together with a shell) in order to implement the "directory wildcard" expansion. * lisp/dired.el (dired-insert-directory): Make the "directory wildcard" code obey `files--use-insert-directory-program-p`, using `file-expand-wildcards`. * lisp/ls-lisp.el (ls-lisp--dired, ls-lisp-unload-function): Delete funs. (dired): Don't advise any more. diff --git a/lisp/dired.el b/lisp/dired.el index c11b107213b..ace4bbf5776 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1696,7 +1696,7 @@ dired-insert-directory ;; Expand directory wildcards and fill file-list. (let ((dir-wildcard (and (null file-list) wildcard (insert-directory-wildcard-in-dir-p dir)))) - (cond (dir-wildcard + (cond ((and dir-wildcard (files--use-insert-directory-program-p)) (setq switches (concat "-d " switches)) (let* ((default-directory (car dir-wildcard)) (script (format "%s %s %s" @@ -1723,12 +1723,15 @@ dired-insert-directory ;; month names; but this should not be necessary any ;; more, with the new value of ;; `directory-listing-before-filename-regexp'. - (file-list - (dolist (f file-list) - (let ((beg (point))) - (insert-directory f switches nil nil) - ;; Re-align fields, if necessary. - (dired-align-file beg (point))))) + ((or file-list dir-wildcard) + (let ((default-directory + (or (car dir-wildcard) default-directory))) + (dolist (f (or file-list + (file-expand-wildcards (cdr dir-wildcard)))) + (let ((beg (point))) + (insert-directory f switches nil nil) + ;; Re-align fields, if necessary. + (dired-align-file beg (point)))))) (t (insert-directory dir switches wildcard (not wildcard)))) ;; Quote certain characters, unless ls quoted them for us. diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 141d1f32c09..c0a52d76a25 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -449,36 +449,6 @@ ls-lisp-insert-directory "Directory doesn't exist or is inaccessible" file)))))) -(declare-function dired-read-dir-and-switches "dired" (str)) -(declare-function dired-goto-next-file "dired" ()) - -(defun ls-lisp--dired (orig-fun dir-or-list &optional switches) - (interactive (dired-read-dir-and-switches "")) - (unless dir-or-list - (setq dir-or-list default-directory)) - (if (consp dir-or-list) - (funcall orig-fun dir-or-list switches) - (let ((dir-wildcard (insert-directory-wildcard-in-dir-p - (expand-file-name dir-or-list)))) - (if (not dir-wildcard) - (funcall orig-fun dir-or-list switches) - (let* ((default-directory (car dir-wildcard)) - (files (file-expand-wildcards (cdr dir-wildcard))) - (dir (car dir-wildcard))) - (if files - (let ((inhibit-read-only t) - (buf - (apply orig-fun (nconc (list dir) files) (and switches (list switches))))) - (with-current-buffer buf - (save-excursion - (goto-char (point-min)) - (dired-goto-next-file) - (forward-line 0) - (insert " wildcard " (cdr dir-wildcard) "\n")))) - (user-error "No files matching wildcard"))))))) - -(advice-add 'dired :around #'ls-lisp--dired) - (defun ls-lisp-sanitize (file-alist) "Sanitize the elements in FILE-ALIST. Fixes any elements in the alist for directory entries whose file @@ -866,12 +836,6 @@ ls-lisp-format-file-size file-size) (format " %7s" (file-size-human-readable file-size)))) -(defun ls-lisp-unload-function () - "Unload ls-lisp library." - (advice-remove 'dired #'ls-lisp--dired) - ;; Continue standard unloading. - nil) - (defun ls-lisp--sanitize-switches (switches) "Convert long options of GNU \"ls\" to their short form. Conversion is done only for flags supported by ls-lisp. commit 29957969e5199bdab5612af68e33b3989e4bbbd2 Author: Stefan Monnier Date: Sat Dec 9 23:45:56 2023 -0500 (insert-directory): Remove `ls-lisp` advice Rather than have `ls-lisp` advise `insert-directory`, make `insert-directory` call `ls-lisp.el` code directly when needed. * lisp/files.el (files--use-insert-directory-program-p): New function. (insert-directory): Use it to delegate to `ls-lisp--insert-directory` when applicable. * lisp/ls-lisp.el (ls-lisp--insert-directory): Remove `orig-fun` arg. Don't test `ls-lisp-use-insert-directory-program` or check for a magic file name handler; it is now the caller's responsibility. (insert-directory): Don't add advice any more. * lisp/dired.el (ls-lisp-use-insert-directory-program): Don't declare it. (dired-insert-directory): Use `files--use-insert-directory-program-p` instead. (dired-use-ls-dired): Adjust docstring to refer to `insert-directory-program` rather than "ls". diff --git a/lisp/dired.el b/lisp/dired.el index 9162dfbdf4b..c11b107213b 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -119,12 +119,11 @@ dired-chown-program (defcustom dired-use-ls-dired 'unspecified "Non-nil means Dired should pass the \"--dired\" option to \"ls\". If nil, don't pass \"--dired\" to \"ls\". -The special value of `unspecified' means to check whether \"ls\" -supports the \"--dired\" option, and save the result in this -variable. This is performed the first time `dired-insert-directory' -is invoked. (If `ls-lisp' is used by default, the test is performed -only if `ls-lisp-use-insert-directory-program' is non-nil, i.e., if -Dired actually uses \"ls\".) +The special value of `unspecified' means to check whether +`insert-directory-program' supports the \"--dired\" option, and save +the result in this variable. +This is performed the first time `dired-insert-directory' +invokes `insert-directory-program'. Note that if you set this option to nil, either through choice or because your \"ls\" program does not support \"--dired\", Dired @@ -1643,9 +1642,6 @@ dired-align-file (skip-chars-forward "^ ") (skip-chars-forward " ")) (set-marker file nil))))) - -(defvar ls-lisp-use-insert-directory-program) - (defun dired-check-switches (switches short &optional long) "Return non-nil if the string SWITCHES matches LONG or SHORT format." (let (case-fold-search) @@ -1676,11 +1672,8 @@ dired-insert-directory (remotep (file-remote-p dir)) end) (if (and - ;; Don't try to invoke `ls' if we are on DOS/Windows where - ;; ls-lisp emulation is used, except if they want to use `ls' - ;; as indicated by `ls-lisp-use-insert-directory-program'. - (not (and (featurep 'ls-lisp) - (null ls-lisp-use-insert-directory-program))) + ;; Don't try to invoke `ls' if ls-lisp emulation should be used. + (files--use-insert-directory-program-p) ;; FIXME: Big ugly hack for Eshell's eshell-ls-use-in-dired. (not (bound-and-true-p eshell-ls-use-in-dired)) (or remotep diff --git a/lisp/files.el b/lisp/files.el index 3c1d0c30e67..5e1987ec2ff 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7780,6 +7780,16 @@ insert-directory-program :initialize #'custom-initialize-delay :version "30.1") +(defun files--use-insert-directory-program-p () + "Return non-nil if we should use `insert-directory-program'. +Return nil if we should prefer `ls-lisp' instead." + ;; FIXME: Should we also check `file-accessible-directory-p' so we + ;; automatically redirect to ls-lisp when operating on magic file names? + (and (if (boundp 'ls-lisp-use-insert-directory-program) + ls-lisp-use-insert-directory-program + t) + insert-directory-program)) + (defcustom directory-free-space-program (purecopy "df") "Program to get the amount of free space on a file system. We assume the output has the format of `df'. @@ -7972,9 +7982,11 @@ insert-directory Optional fourth arg FULL-DIRECTORY-P means file is a directory and switches do not contain `d', so that a full listing is expected. -This works by running a directory listing program -whose name is in the variable `insert-directory-program'. -If WILDCARD, it also runs the shell specified by `shell-file-name'. +Depending on the value of `ls-lisp-use-insert-directory-program' +this works either using a Lisp emulation of the \"ls\" program +or by running a directory listing program +whose name is in the variable `insert-directory-program' +\(and if WILDCARD, it also runs the shell specified by `shell-file-name'). When SWITCHES contains the long `--dired' option, this function treats it specially, for the sake of dired. However, the @@ -7983,184 +7995,191 @@ insert-directory ;; We need the directory in order to find the right handler. (let ((handler (find-file-name-handler (expand-file-name file) 'insert-directory))) - (if handler - (funcall handler 'insert-directory file switches - wildcard full-directory-p) - (let (result (beg (point))) - - ;; Read the actual directory using `insert-directory-program'. - ;; RESULT gets the status code. - (let* (;; We at first read by no-conversion, then after - ;; putting text property `dired-filename, decode one - ;; bunch by one to preserve that property. - (coding-system-for-read 'no-conversion) - ;; This is to control encoding the arguments in call-process. - (coding-system-for-write - (and enable-multibyte-characters - (or file-name-coding-system - default-file-name-coding-system)))) - (setq result - (if wildcard - ;; If the wildcard is just in the file part, then run ls in - ;; the directory part of the file pattern using the last - ;; component as argument. Otherwise, run ls in the longest - ;; subdirectory of the directory part free of wildcards; use - ;; the remaining of the file pattern as argument. - (let* ((dir-wildcard (insert-directory-wildcard-in-dir-p file)) - (default-directory - (cond (dir-wildcard (car dir-wildcard)) - (t - (if (file-name-absolute-p file) - (file-name-directory file) - (file-name-directory (expand-file-name file)))))) - (pattern (if dir-wildcard (cdr dir-wildcard) (file-name-nondirectory file)))) - ;; NB since switches is passed to the shell, be - ;; careful of malicious values, eg "-l;reboot". - ;; See eg dired-safe-switches-p. - (call-process - shell-file-name nil t nil - shell-command-switch - (concat (if (memq system-type '(ms-dos windows-nt)) - "" - "\\") ; Disregard Unix shell aliases! - insert-directory-program - " -d " - (if (stringp switches) - switches - (mapconcat 'identity switches " ")) - " -- " - ;; Quote some characters that have - ;; special meanings in shells; but - ;; don't quote the wildcards--we want - ;; them to be special. We also - ;; currently don't quote the quoting - ;; characters in case people want to - ;; use them explicitly to quote - ;; wildcard characters. - (shell-quote-wildcard-pattern pattern)))) - ;; SunOS 4.1.3, SVr4 and others need the "." to list the - ;; directory if FILE is a symbolic link. - (unless full-directory-p - (setq switches - (cond - ((stringp switches) (concat switches " -d")) - ((member "-d" switches) switches) - (t (append switches '("-d")))))) - (if (string-match "\\`~" file) - (setq file (expand-file-name file))) - (apply 'call-process - insert-directory-program nil t nil - (append - (if (listp switches) switches - (unless (equal switches "") - ;; Split the switches at any spaces so we can - ;; pass separate options as separate args. - (split-string-and-unquote switches))) - ;; Avoid lossage if FILE starts with `-'. - '("--") - (list file)))))) - - ;; If we got "//DIRED//" in the output, it means we got a real - ;; directory listing, even if `ls' returned nonzero. - ;; So ignore any errors. - (when (if (stringp switches) - (string-match "--dired\\>" switches) - (member "--dired" switches)) - (save-excursion - (forward-line -2) - (when (looking-at "//SUBDIRED//") - (forward-line -1)) - (if (looking-at "//DIRED//") - (setq result 0)))) - - (when (and (not (eq 0 result)) - (eq insert-directory-ls-version 'unknown)) - ;; The first time ls returns an error, - ;; find the version numbers of ls, - ;; and set insert-directory-ls-version - ;; to > if it is more than 5.2.1, < if it is less, nil if it - ;; is equal or if the info cannot be obtained. - ;; (That can mean it isn't GNU ls.) - (let ((version-out - (with-temp-buffer - (call-process "ls" nil t nil "--version") - (buffer-string)))) - (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out) - (let* ((version (match-string 1 version-out)) - (split (split-string version "[.]")) - (numbers (mapcar 'string-to-number split)) - (min '(5 2 1)) - comparison) - (while (and (not comparison) (or numbers min)) - (cond ((null min) - (setq comparison '>)) - ((null numbers) - (setq comparison '<)) - ((> (car numbers) (car min)) - (setq comparison '>)) - ((< (car numbers) (car min)) - (setq comparison '<)) - (t - (setq numbers (cdr numbers) - min (cdr min))))) - (setq insert-directory-ls-version (or comparison '=))) - (setq insert-directory-ls-version nil)))) - - ;; For GNU ls versions 5.2.2 and up, ignore minor errors. - (when (and (eq 1 result) (eq insert-directory-ls-version '>)) - (setq result 0)) - - ;; If `insert-directory-program' failed, signal an error. - (unless (eq 0 result) - ;; Delete the error message it may have output. - (delete-region beg (point)) - ;; On non-Posix systems, we cannot open a directory, so - ;; don't even try, because that will always result in - ;; the ubiquitous "Access denied". Instead, show the - ;; command line so the user can try to guess what went wrong. - (if (and (file-directory-p file) - (memq system-type '(ms-dos windows-nt))) - (error - "Reading directory: \"%s %s -- %s\" exited with status %s" - insert-directory-program - (if (listp switches) (concat switches) switches) - file result) - ;; Unix. Access the file to get a suitable error. - (access-file file "Reading directory") - (error "Listing directory failed but `access-file' worked"))) - (insert-directory-clean beg switches) - ;; Now decode what read if necessary. - (let ((coding (or coding-system-for-read - file-name-coding-system - default-file-name-coding-system - 'undecided)) - coding-no-eol - val pos) - (when (and enable-multibyte-characters - (not (memq (coding-system-base coding) - '(raw-text no-conversion)))) - ;; If no coding system is specified or detection is - ;; requested, detect the coding. - (if (eq (coding-system-base coding) 'undecided) - (setq coding (detect-coding-region beg (point) t))) - (if (not (eq (coding-system-base coding) 'undecided)) - (save-restriction - (setq coding-no-eol - (coding-system-change-eol-conversion coding 'unix)) - (narrow-to-region beg (point)) - (goto-char (point-min)) - (while (not (eobp)) - (setq pos (point) - val (get-text-property (point) 'dired-filename)) - (goto-char (next-single-property-change - (point) 'dired-filename nil (point-max))) - ;; Force no eol conversion on a file name, so - ;; that CR is preserved. - (decode-coding-region pos (point) - (if val coding-no-eol coding)) - (if val - (put-text-property pos (point) - 'dired-filename t))))))))))) + (cond + (handler + (funcall handler 'insert-directory file switches + wildcard full-directory-p)) + ((not (files--use-insert-directory-program-p)) + (require 'ls-lisp) + (declare-function ls-lisp--insert-directory "ls-lisp") + (ls-lisp--insert-directory file switches wildcard full-directory-p)) + (t + (let (result (beg (point))) + + ;; Read the actual directory using `insert-directory-program'. + ;; RESULT gets the status code. + (let* (;; We at first read by no-conversion, then after + ;; putting text property `dired-filename, decode one + ;; bunch by one to preserve that property. + (coding-system-for-read 'no-conversion) + ;; This is to control encoding the arguments in call-process. + (coding-system-for-write + (and enable-multibyte-characters + (or file-name-coding-system + default-file-name-coding-system)))) + (setq result + (if wildcard + ;; If the wildcard is just in the file part, then run ls in + ;; the directory part of the file pattern using the last + ;; component as argument. Otherwise, run ls in the longest + ;; subdirectory of the directory part free of wildcards; use + ;; the remaining of the file pattern as argument. + (let* ((dir-wildcard (insert-directory-wildcard-in-dir-p file)) + (default-directory + (cond (dir-wildcard (car dir-wildcard)) + (t + (if (file-name-absolute-p file) + (file-name-directory file) + (file-name-directory (expand-file-name file)))))) + (pattern (if dir-wildcard (cdr dir-wildcard) (file-name-nondirectory file)))) + ;; NB since switches is passed to the shell, be + ;; careful of malicious values, eg "-l;reboot". + ;; See eg dired-safe-switches-p. + (call-process + shell-file-name nil t nil + shell-command-switch + (concat (if (memq system-type '(ms-dos windows-nt)) + "" + "\\") ; Disregard Unix shell aliases! + insert-directory-program + " -d " + (if (stringp switches) + switches + (mapconcat #'identity switches " ")) + " -- " + ;; Quote some characters that have + ;; special meanings in shells; but + ;; don't quote the wildcards--we want + ;; them to be special. We also + ;; currently don't quote the quoting + ;; characters in case people want to + ;; use them explicitly to quote + ;; wildcard characters. + (shell-quote-wildcard-pattern pattern)))) + ;; SunOS 4.1.3, SVr4 and others need the "." to list the + ;; directory if FILE is a symbolic link. + (unless full-directory-p + (setq switches + (cond + ((stringp switches) (concat switches " -d")) + ((member "-d" switches) switches) + (t (append switches '("-d")))))) + (if (string-match "\\`~" file) + (setq file (expand-file-name file))) + (apply #'call-process + insert-directory-program nil t nil + (append + (if (listp switches) switches + (unless (equal switches "") + ;; Split the switches at any spaces so we can + ;; pass separate options as separate args. + (split-string-and-unquote switches))) + ;; Avoid lossage if FILE starts with `-'. + '("--") + (list file)))))) + + ;; If we got "//DIRED//" in the output, it means we got a real + ;; directory listing, even if `ls' returned nonzero. + ;; So ignore any errors. + (when (if (stringp switches) + (string-match "--dired\\>" switches) + (member "--dired" switches)) + (save-excursion + (forward-line -2) + (when (looking-at "//SUBDIRED//") + (forward-line -1)) + (if (looking-at "//DIRED//") + (setq result 0)))) + + (when (and (not (eq 0 result)) + (eq insert-directory-ls-version 'unknown)) + ;; The first time ls returns an error, + ;; find the version numbers of ls, + ;; and set insert-directory-ls-version + ;; to > if it is more than 5.2.1, < if it is less, nil if it + ;; is equal or if the info cannot be obtained. + ;; (That can mean it isn't GNU ls.) + (let ((version-out + (with-temp-buffer + (call-process "ls" nil t nil "--version") + (buffer-string)))) + (setq insert-directory-ls-version + (if (string-match "ls (.*utils) \\([0-9.]*\\)$" version-out) + (let* ((version (match-string 1 version-out)) + (split (split-string version "[.]")) + (numbers (mapcar #'string-to-number split)) + (min '(5 2 1)) + comparison) + (while (and (not comparison) (or numbers min)) + (cond ((null min) + (setq comparison #'>)) + ((null numbers) + (setq comparison #'<)) + ((> (car numbers) (car min)) + (setq comparison #'>)) + ((< (car numbers) (car min)) + (setq comparison #'<)) + (t + (setq numbers (cdr numbers) + min (cdr min))))) + (or comparison #'=)) + nil)))) + + ;; For GNU ls versions 5.2.2 and up, ignore minor errors. + (when (and (eq 1 result) (eq insert-directory-ls-version #'>)) + (setq result 0)) + + ;; If `insert-directory-program' failed, signal an error. + (unless (eq 0 result) + ;; Delete the error message it may have output. + (delete-region beg (point)) + ;; On non-Posix systems, we cannot open a directory, so + ;; don't even try, because that will always result in + ;; the ubiquitous "Access denied". Instead, show the + ;; command line so the user can try to guess what went wrong. + (if (and (file-directory-p file) + (memq system-type '(ms-dos windows-nt))) + (error + "Reading directory: \"%s %s -- %s\" exited with status %s" + insert-directory-program + (if (listp switches) (concat switches) switches) + file result) + ;; Unix. Access the file to get a suitable error. + (access-file file "Reading directory") + (error "Listing directory failed but `access-file' worked"))) + (insert-directory-clean beg switches) + ;; Now decode what read if necessary. + (let ((coding (or coding-system-for-read + file-name-coding-system + default-file-name-coding-system + 'undecided)) + coding-no-eol + val pos) + (when (and enable-multibyte-characters + (not (memq (coding-system-base coding) + '(raw-text no-conversion)))) + ;; If no coding system is specified or detection is + ;; requested, detect the coding. + (if (eq (coding-system-base coding) 'undecided) + (setq coding (detect-coding-region beg (point) t))) + (if (not (eq (coding-system-base coding) 'undecided)) + (save-restriction + (setq coding-no-eol + (coding-system-change-eol-conversion coding 'unix)) + (narrow-to-region beg (point)) + (goto-char (point-min)) + (while (not (eobp)) + (setq pos (point) + val (get-text-property (point) 'dired-filename)) + (goto-char (next-single-property-change + (point) 'dired-filename nil (point-max))) + ;; Force no eol conversion on a file name, so + ;; that CR is preserved. + (decode-coding-region pos (point) + (if val coding-no-eol coding)) + (if val + (put-text-property pos (point) + 'dired-filename t)))))))))))) (defun insert-directory-adj-pos (pos error-lines) "Convert `ls --dired' file name position value POS to a buffer position. diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 1066f38c050..141d1f32c09 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -249,89 +249,69 @@ ls-lisp-filesize-b-fmt ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defun ls-lisp--insert-directory (orig-fun file switches &optional wildcard full-directory-p) +(defun ls-lisp--insert-directory (file switches wildcard full-directory-p) "Insert directory listing for FILE, formatted according to SWITCHES. -Leaves point after the inserted text. -SWITCHES may be a string of options, or a list of strings. -Optional third arg WILDCARD means treat FILE as shell wildcard. -Optional fourth arg FULL-DIRECTORY-P means file is a directory and -switches do not contain `d', so that a full listing is expected. - -This version of the function comes from `ls-lisp.el'. -If the value of `ls-lisp-use-insert-directory-program' is non-nil then -this advice just delegates the work to ORIG-FUN (the normal `insert-directory' -function from `files.el'). -But if the value of `ls-lisp-use-insert-directory-program' is nil -then it runs a Lisp emulation. - -The Lisp emulation does not run any external programs or shells. It -supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards' +This implementation of `insert-directory' works using Lisp functions rather +than `insert-directory-program'. + +This Lisp emulation does not run any external programs or shells. + It supports ordinary shell wildcards if `ls-lisp-support-shell-wildcards' is non-nil; otherwise, it interprets wildcards as regular expressions to match file names. It does not support all `ls' switches -- those that work are: A a B C c F G g h i n R r S s t U u v X. The l switch is assumed to be always present and cannot be turned off. Long variants of the above switches, as documented for GNU `ls', are also supported; unsupported long options are silently ignored." - (if ls-lisp-use-insert-directory-program - (funcall orig-fun - file switches wildcard full-directory-p) - ;; We need the directory in order to find the right handler. - (setq switches (or switches "")) - (let ((handler (find-file-name-handler (expand-file-name file) - 'insert-directory)) - (orig-file file) - wildcard-regexp - (ls-lisp-dirs-first - (or ls-lisp-dirs-first - (string-match "--group-directories-first" switches)))) - (if handler - (funcall handler 'insert-directory file switches - wildcard full-directory-p) - (when (string-match "--group-directories-first" switches) - ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in - ;; reverse order: - (setq ls-lisp-dirs-first t) - (setq switches (replace-match "" nil nil switches))) - ;; Remove unrecognized long options, and convert the - ;; recognized ones to their short variants. - (setq switches (ls-lisp--sanitize-switches switches)) - ;; Convert SWITCHES to a list of characters. - (setq switches (delete ?\ (delete ?- (append switches nil)))) - ;; Sometimes we get ".../foo*/" as FILE. While the shell and - ;; `ls' don't mind, we certainly do, because it makes us think - ;; there is no wildcard, only a directory name. - (if (and ls-lisp-support-shell-wildcards - (string-match "[[?*]" file) - ;; Prefer an existing file to wildcards, like - ;; dired-noselect does. - (not (file-exists-p file))) - (progn - (or (not (eq (aref file (1- (length file))) ?/)) - (setq file (substring file 0 (1- (length file))))) - (setq wildcard t))) - (if wildcard - (setq wildcard-regexp - (if ls-lisp-support-shell-wildcards - (wildcard-to-regexp (file-name-nondirectory file)) - (file-name-nondirectory file)) - file (file-name-directory file)) - (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'"))) - (condition-case err - (ls-lisp-insert-directory - file switches (ls-lisp-time-index switches) - wildcard-regexp full-directory-p) - (invalid-regexp - ;; Maybe they wanted a literal file that just happens to - ;; use characters special to shell wildcards. - (if (equal (cadr err) "Unmatched [ or [^") - (progn - (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'") - file (file-relative-name orig-file)) - (ls-lisp-insert-directory - file switches (ls-lisp-time-index switches) - nil full-directory-p)) - (signal (car err) (cdr err))))))))) -(advice-add 'insert-directory :around #'ls-lisp--insert-directory) + (setq switches (or switches "")) + (let ((orig-file file) + wildcard-regexp + (ls-lisp-dirs-first + (or ls-lisp-dirs-first + (string-match "--group-directories-first" switches)))) + (when (string-match "--group-directories-first" switches) + ;; if ls-lisp-dirs-first is nil, dirs are grouped but come out in + ;; reverse order: + (setq ls-lisp-dirs-first t) + (setq switches (replace-match "" nil nil switches))) + ;; Remove unrecognized long options, and convert the + ;; recognized ones to their short variants. + (setq switches (ls-lisp--sanitize-switches switches)) + ;; Convert SWITCHES to a list of characters. + (setq switches (delete ?\ (delete ?- (append switches nil)))) + ;; Sometimes we get ".../foo*/" as FILE. While the shell and + ;; `ls' don't mind, we certainly do, because it makes us think + ;; there is no wildcard, only a directory name. + (if (and ls-lisp-support-shell-wildcards + (string-match "[[?*]" file) + ;; Prefer an existing file to wildcards, like + ;; dired-noselect does. + (not (file-exists-p file))) + (progn + (or (not (eq (aref file (1- (length file))) ?/)) + (setq file (substring file 0 (1- (length file))))) + (setq wildcard t))) + (if wildcard + (setq wildcard-regexp + (if ls-lisp-support-shell-wildcards + (wildcard-to-regexp (file-name-nondirectory file)) + (file-name-nondirectory file)) + file (file-name-directory file)) + (if (memq ?B switches) (setq wildcard-regexp "[^~]\\'"))) + (condition-case err + (ls-lisp-insert-directory + file switches (ls-lisp-time-index switches) + wildcard-regexp full-directory-p) + (invalid-regexp + ;; Maybe they wanted a literal file that just happens to + ;; use characters special to shell wildcards. + (if (equal (cadr err) "Unmatched [ or [^") + (progn + (setq wildcard-regexp (if (memq ?B switches) "[^~]\\'") + file (file-relative-name orig-file)) + (ls-lisp-insert-directory + file switches (ls-lisp-time-index switches) + nil full-directory-p)) + (signal (car err) (cdr err))))))) (defun ls-lisp-insert-directory (file switches time-index wildcard-regexp full-directory-p) @@ -888,7 +868,6 @@ ls-lisp-format-file-size (defun ls-lisp-unload-function () "Unload ls-lisp library." - (advice-remove 'insert-directory #'ls-lisp--insert-directory) (advice-remove 'dired #'ls-lisp--dired) ;; Continue standard unloading. nil) commit f7cf85c3879c6857e8478bef41cce25a94759fb8 Author: Stefan Monnier Date: Sat Dec 9 22:55:32 2023 -0500 (dired-insert-directory): Obey `file-list` and `wildcard` Commit 6f6639d6ed6c's support for wildcards in directories failed to obey `file-list` and `wildcard` arguments. Fix it. * lisp/dired.el (dired-insert-directory): Expand directory wildcards only if `file-list` is nil and `wildcard` is non-nil. Also, refer back to `dir-wildcard` instead of recomputing it. (dired-readin-insert): Pass a non-nil `wildcard` when wildcard expansion might be needed to preserve former behavior. diff --git a/lisp/dired.el b/lisp/dired.el index 36ca54efc37..9162dfbdf4b 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -1521,18 +1521,21 @@ dired-readin-insert (setq dir dired-directory file-list nil)) (setq dir (expand-file-name dir)) - (if (and (equal "" (file-name-nondirectory dir)) - (not file-list)) - ;; If we are reading a whole single directory... - (dired-insert-directory dir dired-actual-switches nil nil t) - (if (and (not (insert-directory-wildcard-in-dir-p dir)) - (not (file-readable-p - (directory-file-name (file-name-directory dir))))) - (error "Directory %s inaccessible or nonexistent" dir)) + (cond + ((and (equal "" (file-name-nondirectory dir)) + (not file-list)) + ;; If we are reading a whole single directory... + (dired-insert-directory dir dired-actual-switches nil + (not (file-directory-p dir)) t)) + ((not (or (insert-directory-wildcard-in-dir-p dir) + (file-readable-p + (directory-file-name (file-name-directory dir))))) + (error "Directory %s inaccessible or nonexistent" dir)) + (t ;; Else treat it as a wildcard spec ;; unless we have an explicit list of files. (dired-insert-directory dir dired-actual-switches - file-list (not file-list) t)))) + file-list (not file-list) t))))) (defun dired-align-file (beg end) "Align the fields of a file to the ones of surrounding lines. @@ -1541,7 +1544,7 @@ dired-align-file ;; hold the largest element ("largest" in the current invocation, of ;; course). So when a single line is output, the size of each field is ;; just big enough for that one output. Thus when dired refreshes one - ;; line, the alignment if this line w.r.t the rest is messed up because + ;; line, the alignment of this line w.r.t the rest is messed up because ;; the fields of that one line will generally be smaller. ;; ;; To work around this problem, we here add spaces to try and @@ -1698,7 +1701,8 @@ dired-insert-directory (unless remotep (setq switches (concat "--dired -N " switches)))) ;; Expand directory wildcards and fill file-list. - (let ((dir-wildcard (insert-directory-wildcard-in-dir-p dir))) + (let ((dir-wildcard (and (null file-list) wildcard + (insert-directory-wildcard-in-dir-p dir)))) (cond (dir-wildcard (setq switches (concat "-d " switches)) (let* ((default-directory (car dir-wildcard)) @@ -1722,78 +1726,78 @@ dired-insert-directory (user-error "%s: No files matching wildcard" (cdr dir-wildcard))) (insert-directory-clean (point) switches))) - (t - ;; We used to specify the C locale here, to force English - ;; month names; but this should not be necessary any - ;; more, with the new value of - ;; `directory-listing-before-filename-regexp'. - (if file-list - (dolist (f file-list) - (let ((beg (point))) - (insert-directory f switches nil nil) - ;; Re-align fields, if necessary. - (dired-align-file beg (point)))) - (insert-directory dir switches wildcard (not wildcard)))))) - ;; Quote certain characters, unless ls quoted them for us. - (if (not (dired-switches-escape-p dired-actual-switches)) + ;; We used to specify the C locale here, to force English + ;; month names; but this should not be necessary any + ;; more, with the new value of + ;; `directory-listing-before-filename-regexp'. + (file-list + (dolist (f file-list) + (let ((beg (point))) + (insert-directory f switches nil nil) + ;; Re-align fields, if necessary. + (dired-align-file beg (point))))) + (t + (insert-directory dir switches wildcard (not wildcard)))) + ;; Quote certain characters, unless ls quoted them for us. + (if (not (dired-switches-escape-p dired-actual-switches)) + (save-excursion + (setq end (point-marker)) + (goto-char opoint) + (while (search-forward "\\" end t) + (replace-match (apply #'propertize + "\\\\" + (text-properties-at (match-beginning 0))) + nil t)) + (goto-char opoint) + (while (search-forward "\^m" end t) + (replace-match (apply #'propertize + "\\015" + (text-properties-at (match-beginning 0))) + nil t)) + (set-marker end nil)) + ;; Replace any newlines in DIR with literal "\n"s, for the sake + ;; of the header line. To disambiguate a literal "\n" in the + ;; actual dirname, we also replace "\" with "\\". + ;; Personally, I think this should always be done, irrespective + ;; of the value of dired-actual-switches, because: + ;; i) Dired simply does not work with an unescaped newline in + ;; the directory name used in the header (bug=10469#28), and + ;; ii) "\" is always replaced with "\\" in the listing, so doing + ;; it in the header as well makes things consistent. + ;; But at present it is only done if "-b" is in ls-switches, + ;; because newlines in dirnames are uncommon, and people may + ;; have gotten used to seeing unescaped "\" in the headers. + ;; Note: adjust dired-build-subdir-alist if you change this. + (setq dir (string-replace "\\" "\\\\" dir) + dir (string-replace "\n" "\\n" dir))) + ;; If we used --dired and it worked, the lines are already indented. + ;; Otherwise, indent them. + (unless (save-excursion + (goto-char opoint) + (looking-at-p " ")) + (let ((indent-tabs-mode nil)) + (indent-rigidly opoint (point) 2))) + ;; Insert text at the beginning to standardize things. + (let ((content-point opoint)) (save-excursion - (setq end (point-marker)) (goto-char opoint) - (while (search-forward "\\" end t) - (replace-match (apply #'propertize - "\\\\" - (text-properties-at (match-beginning 0))) - nil t)) - (goto-char opoint) - (while (search-forward "\^m" end t) - (replace-match (apply #'propertize - "\\015" - (text-properties-at (match-beginning 0))) - nil t)) - (set-marker end nil)) - ;; Replace any newlines in DIR with literal "\n"s, for the sake - ;; of the header line. To disambiguate a literal "\n" in the - ;; actual dirname, we also replace "\" with "\\". - ;; Personally, I think this should always be done, irrespective - ;; of the value of dired-actual-switches, because: - ;; i) Dired simply does not work with an unescaped newline in - ;; the directory name used in the header (bug=10469#28), and - ;; ii) "\" is always replaced with "\\" in the listing, so doing - ;; it in the header as well makes things consistent. - ;; But at present it is only done if "-b" is in ls-switches, - ;; because newlines in dirnames are uncommon, and people may - ;; have gotten used to seeing unescaped "\" in the headers. - ;; Note: adjust dired-build-subdir-alist if you change this. - (setq dir (string-replace "\\" "\\\\" dir) - dir (string-replace "\n" "\\n" dir))) - ;; If we used --dired and it worked, the lines are already indented. - ;; Otherwise, indent them. - (unless (save-excursion - (goto-char opoint) - (looking-at-p " ")) - (let ((indent-tabs-mode nil)) - (indent-rigidly opoint (point) 2))) - ;; Insert text at the beginning to standardize things. - (let ((content-point opoint)) - (save-excursion - (goto-char opoint) - (when (and (or hdr wildcard) - (not (and (looking-at "^ \\(.*\\):$") - (file-name-absolute-p (match-string 1))))) - ;; Note that dired-build-subdir-alist will replace the name - ;; by its expansion, so it does not matter whether what we insert - ;; here is fully expanded, but it should be absolute. - (insert " " (or (car-safe (insert-directory-wildcard-in-dir-p dir)) - (directory-file-name (file-name-directory dir))) - ":\n") - (setq content-point (point))) - (when wildcard - ;; Insert "wildcard" line where "total" line would be for a full dir. - (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir)) - (file-name-nondirectory dir)) - "\n")) - (setq content-point (dired--insert-disk-space opoint dir))) - (dired-insert-set-properties content-point (point))))) + (when (and (or hdr wildcard) + (not (and (looking-at "^ \\(.*\\):$") + (file-name-absolute-p (match-string 1))))) + ;; Note that dired-build-subdir-alist will replace the name + ;; by its expansion, so it does not matter whether what we insert + ;; here is fully expanded, but it should be absolute. + (insert " " (or (car-safe dir-wildcard) + (directory-file-name (file-name-directory dir))) + ":\n") + (setq content-point (point))) + (when wildcard + ;; Insert "wildcard" line where "total" line would be for a full dir. + (insert " wildcard " (or (cdr-safe (insert-directory-wildcard-in-dir-p dir)) + (file-name-nondirectory dir)) + "\n")) + (setq content-point (dired--insert-disk-space opoint dir))) + (dired-insert-set-properties content-point (point)))))) (defun dired--insert-disk-space (beg file) ;; Try to insert the amount of free space. diff --git a/test/lisp/dired-tests.el b/test/lisp/dired-tests.el index 8f2b9af09c0..599cfa0ce77 100644 --- a/test/lisp/dired-tests.el +++ b/test/lisp/dired-tests.el @@ -270,8 +270,8 @@ dired-test-bug27631 "Test for https://debbugs.gnu.org/27631 ." ;; For dired using 'ls' emulation we test for this bug in ;; ls-lisp-tests.el and em-ls-tests.el. - (skip-unless (and (not (featurep 'ls-lisp)) - (not (featurep 'eshell)))) + (skip-unless (not (or (featurep 'ls-lisp) + (featurep 'eshell)))) (ert-with-temp-directory dir (let* ((dir1 (expand-file-name "dir1" dir)) (dir2 (expand-file-name "dir2" dir)) commit 6cc1418fc3e8107cab2c9824c367ba7762235aef Author: Stefan Monnier Date: Sat Dec 9 19:46:07 2023 -0500 (file-expand-wildcards): Handle patterns ending in "/" The bug was encountered via the ls-lisp advice on Dired but it actually affects all uses of `file-expand-wildcards`, so better fix it there. * lisp/files.el (file-expand-wildcards): Fix bug#60819. * lisp/ls-lisp.el (ls-lisp--dired): Undo commit b365a7cc32e2. * test/lisp/files-tests.el (files-tests--expand-wildcards): New test. diff --git a/lisp/files.el b/lisp/files.el index 047854d3939..3c1d0c30e67 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7547,27 +7547,34 @@ file-expand-wildcards (dolist (dir (nreverse dirs)) (when (or (null dir) ; Possible if DIRPART is not wild. (file-accessible-directory-p dir)) - (let ((this-dir-contents - ;; Filter out "." and ".." - (delq nil - (mapcar (lambda (name) - (unless (string-match "\\`\\.\\.?\\'" - (file-name-nondirectory name)) - name)) - (directory-files - (or dir ".") full - (if regexp - ;; We're matching each file name - ;; element separately. - (concat "\\`" nondir "\\'") - (wildcard-to-regexp nondir))))))) - (setq contents - (nconc - (if (and dir (not full)) - (mapcar (lambda (name) (concat dir name)) - this-dir-contents) - this-dir-contents) - contents))))) + (if (equal "" nondir) + ;; `nondir' is "" when the pattern ends in "/". Basically "" + ;; refers to the directory itself, like ".", but it's not + ;; among the names returned by `directory-files', so we have + ;; to special-case it. + (push (or dir nondir) contents) + (let ((this-dir-contents + ;; Filter out "." and ".." + (delq nil + (mapcar (lambda (name) + (unless (string-match "\\`\\.\\.?\\'" + (file-name-nondirectory + name)) + name)) + (directory-files + (or dir ".") full + (if regexp + ;; We're matching each file name + ;; element separately. + (concat "\\`" nondir "\\'") + (wildcard-to-regexp nondir))))))) + (setq contents + (nconc + (if (and dir (not full)) + (mapcar (lambda (name) (concat dir name)) + this-dir-contents) + this-dir-contents) + contents)))))) contents))) (defcustom find-sibling-rules nil @@ -7757,7 +7764,7 @@ insert-directory-program (purecopy "ls")) "Absolute or relative name of the `ls'-like program. This is used by `insert-directory' and `dired-insert-directory' -(thus, also by `dired'). For Dired, this should ideally point to +\(thus, also by `dired'). For Dired, this should ideally point to GNU ls, or another version of ls that supports the \"--dired\" flag. See `dired-use-ls-dired'. diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index c576819c5d0..1066f38c050 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -483,22 +483,8 @@ ls-lisp--dired (if (not dir-wildcard) (funcall orig-fun dir-or-list switches) (let* ((default-directory (car dir-wildcard)) - (wildcard (cdr dir-wildcard)) - (files (file-expand-wildcards wildcard)) + (files (file-expand-wildcards (cdr dir-wildcard))) (dir (car dir-wildcard))) - ;; When the wildcard ends in a slash, file-expand-wildcards - ;; returns nil; fix that by treating the wildcards as - ;; specifying only directories whose names match the - ;; widlcard. - (if (and (null files) - (directory-name-p wildcard)) - (setq files - (delq nil - (mapcar (lambda (fname) - (if (file-accessible-directory-p fname) - fname)) - (file-expand-wildcards - (directory-file-name wildcard)))))) (if files (let ((inhibit-read-only t) (buf diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index 3e499fff468..24b144c4247 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -2101,5 +2101,9 @@ files-load-elc-gz-file (should (documentation 'bar)) (should (documentation 'zot))))) +(ert-deftest files-tests--expand-wildcards () + (should (file-expand-wildcards + (concat (directory-file-name default-directory) "*/")))) + (provide 'files-tests) ;;; files-tests.el ends here commit 1da0fccc646d1921782dd6d701bc86004cfb3732 Author: Stefan Monnier Date: Sat Dec 9 18:42:36 2023 -0500 * lisp/files.el (file-expand-wildcards): Fix sorting of subdirs E.g. (file-expand-wildcards "/u*/*m*") returned ("/usr/games" "/u/dummy" "/u/monnier" "/u/omnibook-disk") instead of ("/u/dummy" "/u/monnier" "/u/omnibook-disk" "/usr/games"). diff --git a/lisp/files.el b/lisp/files.el index 1cdcec23b11..047854d3939 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -7539,12 +7539,12 @@ file-expand-wildcards ;; if DIRPART contains wildcards. (dirs (if (and dirpart (string-match "[[*?]" (file-local-name dirpart))) - (mapcar 'file-name-as-directory + (mapcar #'file-name-as-directory (file-expand-wildcards (directory-file-name dirpart) nil regexp)) (list dirpart))) contents) - (dolist (dir dirs) + (dolist (dir (nreverse dirs)) (when (or (null dir) ; Possible if DIRPART is not wild. (file-accessible-directory-p dir)) (let ((this-dir-contents