commit aad63f935f8737598835612b53bc3b53c124661f (HEAD, refs/remotes/origin/master) Author: Po Lu Date: Fri Apr 5 15:04:09 2024 +0800 Enable relinquishing access to Android content directories * doc/emacs/android.texi (Android Document Providers): Document new command. * java/org/gnu/emacs/EmacsService.java (relinquishUriRights): New function. * src/Makefile.in (SOME_MACHINE_OBJECTS): Add androidvfs.c. * src/android.c (android_init_emacs_service): Link to new function. * src/android.h (struct android_emacs_service) : New field. * src/androidfns.c: * src/androidvfs.c (android_saf_tree_name) (android_saf_tree_opendir): Minor adjustments to commentary. (Fandroid_relinquish_directory_access): New function. (syms_of_androidvfs): Define new subr. diff --git a/doc/emacs/android.texi b/doc/emacs/android.texi index c9f93429deb..ebc00c74ede 100644 --- a/doc/emacs/android.texi +++ b/doc/emacs/android.texi @@ -299,8 +299,8 @@ on some proprietary versions of Android. @cindex /content/storage directory, Android Android 5.0 introduces a new sort of program, the ``document -provider'': these programs are small programs that provide access to -their own files outside both the asset manager and the Unix +provider'': these programs are small services that provide access to +their own files independently of the asset manager and the Unix filesystem. Emacs supports accessing files and directories they provide, placing their files within the directory @file{/content/storage}. @@ -311,12 +311,15 @@ first request the right to access it. This is done by running the command (@pxref{M-x}) @code{android-request-directory-access}, which displays a file selection dialog. - If a directory is selected within this dialog, its contents are + If a directory is selected from this dialog, its contents are subsequently made available within a new directory named -@file{/content/storage/@var{authority}/@var{id}}, where -@var{authority} is the name of the document provider, and @var{id} is -a unique identifier assigned to the directory by the document -provider. +@file{/content/storage/@var{authority}/@var{id}}, where @var{authority} +is the name of the document provider, and @var{id} is a unique +identifier assigned to the directory by the document provider. + +@findex android-relinquish-directory-access + Such a directory can be deleted once no longer required by providing +its name to the command @code{android-relinquish-directory-access}. The same limitations applied to the @file{/assets} directory (@pxref{Android File System}) are applied when creating sub-processes diff --git a/java/org/gnu/emacs/EmacsService.java b/java/org/gnu/emacs/EmacsService.java index 171b427b05b..34682feeedb 100644 --- a/java/org/gnu/emacs/EmacsService.java +++ b/java/org/gnu/emacs/EmacsService.java @@ -1973,6 +1973,21 @@ In addition, arbitrary runtime exceptions (such as return false; } + /* Relinquish authorization for read and write access to the provided + URI, which is generally a reference to a directory tree. */ + + public void + relinquishUriRights (String uri) + { + Uri uri1; + int flags; + + uri1 = Uri.parse (uri); + flags = (Intent.FLAG_GRANT_READ_URI_PERMISSION + | Intent.FLAG_GRANT_WRITE_URI_PERMISSION); + resolver.releasePersistableUriPermission (uri1, flags); + } + /* Functions for detecting and requesting storage permissions. */ diff --git a/src/Makefile.in b/src/Makefile.in index 9dd88895d27..747ec7d406f 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -494,7 +494,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o hbfont.o \ haikuterm.o haikufns.o haikumenu.o haikufont.o androidterm.o androidfns.o \ - androidfont.o androidselect.c sfntfont-android.c sfntfont.c + androidfont.o androidselect.c androidvfs.c sfntfont-android.c sfntfont.c ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. GMALLOC_OBJ=@GMALLOC_OBJ@ diff --git a/src/android.c b/src/android.c index dcd5c6d99c7..507ffc458d8 100644 --- a/src/android.c +++ b/src/android.c @@ -1690,6 +1690,8 @@ android_init_emacs_service (void) "requestStorageAccess", "()V"); FIND_METHOD (cancel_notification, "cancelNotification", "(Ljava/lang/String;)V"); + FIND_METHOD (relinquish_uri_rights, + "relinquishUriRights", "(Ljava/lang/String;)V"); #undef FIND_METHOD } diff --git a/src/android.h b/src/android.h index 2ca3d7e1446..19adfa38087 100644 --- a/src/android.h +++ b/src/android.h @@ -303,6 +303,7 @@ struct android_emacs_service jmethodID external_storage_available; jmethodID request_storage_access; jmethodID cancel_notification; + jmethodID relinquish_uri_rights; }; extern JNIEnv *android_java_env; diff --git a/src/androidfns.c b/src/androidfns.c index 83cf81c1f07..9f7ac8b69b2 100644 --- a/src/androidfns.c +++ b/src/androidfns.c @@ -3146,7 +3146,7 @@ for more details about these values. */) -/* Directory access requests. */ +/* SAF directory access management. */ DEFUN ("android-request-directory-access", Fandroid_request_directory_access, Sandroid_request_directory_access, 0, 0, "", diff --git a/src/androidvfs.c b/src/androidvfs.c index 2e23ed40cf5..88ea345a298 100644 --- a/src/androidvfs.c +++ b/src/androidvfs.c @@ -4997,7 +4997,7 @@ android_saf_tree_name (struct android_vnode *vnode, char *name, root.vnode.type = ANDROID_VNODE_SAF_ROOT; root.vnode.flags = 0; - /* Find the authority from the URI. */ + /* Derive the authority from the URI. */ fill = (char *) vp->tree_uri; @@ -5647,7 +5647,7 @@ android_saf_tree_opendir (struct android_vnode *vnode) dir->vdir.closedir = android_saf_tree_closedir; dir->vdir.dirfd = android_saf_tree_dirfd; - /* Find the authority from the URI. */ + /* Derive the authority from the URI. */ fill = (char *) vp->tree_uri; @@ -7816,8 +7816,58 @@ android_closedir (struct android_vdir *dirp) +DEFUN ("android-relinquish-directory-access", + Fandroid_relinquish_directory_access, + Sandroid_relinquish_directory_access, 1, 1, + "DDirectory: ", + doc: /* Relinquish access to the provided directory. +DIRECTORY must be an inferior directory to a subdirectory of +/content/storage. Once the command completes, the parent of DIRECTORY +below that subdirectory from will cease to appear there, but no files +will be removed. */) + (Lisp_Object file) +{ + struct android_vnode *vp; + struct android_saf_tree_vnode *saf_tree; + jstring string; + jmethodID method; + + if (android_get_current_api_level () < 21) + error ("Emacs can only access or relinquish application storage on" + " Android 5.0 and later"); + + if (!android_init_gui) + return Qnil; + + file = ENCODE_FILE (Fexpand_file_name (file, Qnil)); + vp = android_name_file (SSDATA (file)); + + if (vp->type != ANDROID_VNODE_SAF_TREE) + { + (*vp->ops->close) (vp); + signal_error ("Access to this directory cannot be relinquished", + file); + } + + saf_tree = (struct android_saf_tree_vnode *) vp; + string = android_build_jstring (saf_tree->tree_uri); + method = service_class.relinquish_uri_rights; + (*android_java_env)->CallNonvirtualVoidMethod (android_java_env, + emacs_service, + service_class.class, + method, string); + (*vp->ops->close) (vp); + android_exception_check_1 (string); + ANDROID_DELETE_LOCAL_REF (string); + return Qnil; +} + + + void syms_of_androidvfs (void) { DEFSYM (Qandroid_jni, "android-jni"); + + defsubr (&Sandroid_relinquish_directory_access); } commit 2637b642d482790bef7486d059f04b60920f1256 Merge: 7a13d012c8e 3cf0bb174ef Author: Po Lu Date: Fri Apr 5 14:08:23 2024 +0800 Merge remote-tracking branch 'savannah/master' into master-android-1 commit 7a13d012c8e17eb25fc8826cdd9ac3e96f912167 Author: Po Lu Date: Fri Apr 5 14:07:44 2024 +0800 Print records inside data-debug * lisp/cedet/data-debug.el (data-debug-insert-stuff-record-button): New function. (data-debug-thing-alist): Register new function. diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el index 83ff451fa99..fda3edd602c 100644 --- a/lisp/cedet/data-debug.el +++ b/lisp/cedet/data-debug.el @@ -598,6 +598,29 @@ PREBUTTONTEXT is some text between prefix and the stuff vector button." ) ) +(defun data-debug-insert-stuff-record-button (stuffvector + prefix + prebuttontext) + "Insert a button representing STUFFVECTOR. +PREFIX is the text that precedes the button. +PREBUTTONTEXT is some text between prefix and the stuff vector button." + (let* ((start (point)) + (end nil) + (str (format "#" (length stuffvector))) + (tip str)) + (insert prefix prebuttontext str) + (setq end (point)) + (put-text-property (- end (length str)) end 'face 'font-lock-variable-name-face) + (put-text-property start end 'ddebug stuffvector) + (put-text-property start end 'ddebug-indent (length prefix)) + (put-text-property start end 'ddebug-prefix prefix) + (put-text-property start end 'help-echo tip) + (put-text-property start end 'ddebug-function + 'data-debug-insert-stuff-vector-from-point) + (insert "\n") + ) + ) + ;;; Symbol ;; @@ -781,6 +804,9 @@ FACE is the face to use." ;; Vector of stuff (vectorp . data-debug-insert-stuff-vector-button) + + ;; Record of stuff + (recordp . data-debug-insert-stuff-record-button) ) "Alist of methods used to insert things into an Ddebug buffer.") commit c57b50569cca1b0d1cc85446ecf6be11326c2a4d Author: Po Lu Date: Fri Apr 5 13:54:07 2024 +0800 Define missing type in semantic/db-find.el * lisp/cedet/semantic/db-find.el (semanticdb-find-result-with-nil): New deftype. diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 551f86a792e..920588abf89 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -928,6 +928,9 @@ but should be good enough for debugging assertions." (semanticdb-find-result-length result) (length result)))) +(cl-deftype semanticdb-find-result-with-nil () + '(satisfies semanticdb-find-result-with-nil-p)) + (defun semanticdb-find-result-with-nil-p (resultp) "Non-nil if RESULTP is in the form of a semanticdb search result. The value nil is valid where a TABLE usually is, but only if the TAG commit 3cf0bb174ef9e5d517f3052a5b8639dddeb249ea Author: Eli Zaretskii Date: Fri Apr 5 08:45:44 2024 +0300 * lisp/hexl.el (hexl-mode): Fix doc string (bug#70163). diff --git a/lisp/hexl.el b/lisp/hexl.el index 1288cf4d7fb..28441a28d6e 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -256,10 +256,10 @@ as that will override any bit grouping options set here." ;;;###autoload (defun hexl-mode (&optional arg) - "\\A mode for editing binary files in hex dump format. -This is not an ordinary major mode; it alters some aspects + "A mode for editing binary files in hex dump format. +\\This is not an ordinary major mode; it alters some aspects of the current mode's behavior, but not all; also, you can exit -Hexl mode and return to the previous mode using `hexl-mode-exit'. +Hexl mode and return to the previous mode using \\[hexl-mode-exit]. This function automatically converts a buffer into the hexl format using the function `hexlify-buffer'. commit 3968b36ae0641e929426991028b49ce66a15af5f Author: Po Lu Date: Fri Apr 5 10:39:33 2024 +0800 Fix Semantic tag discovery when loading of unloaded files is suppressed * lisp/cedet/semantic/db-find.el (semanticdb-find-tags-by-name-method) (semanticdb-find-tags-by-name-regexp-method) (semanticdb-find-tags-for-completion-method) (semanticdb-find-tags-by-class-method) (semanticdb-find-tags-external-children-of-type-method) (semanticdb-find-tags-subclasses-of-type-method) (semanticdb-deep-find-tags-by-name-method) (semanticdb-deep-find-tags-by-name-regexp-method) (semanticdb-deep-find-tags-for-completion-method): Verify that tags is bound before accessing it; this slot is unbound in tables created for unloaded files when the `unloaded' throttle is disabled. diff --git a/lisp/cedet/semantic/db-find.el b/lisp/cedet/semantic/db-find.el index 6d42c3125c0..551f86a792e 100644 --- a/lisp/cedet/semantic/db-find.el +++ b/lisp/cedet/semantic/db-find.el @@ -1307,19 +1307,25 @@ associated with that tag should be loaded into a buffer." "In TABLE, find all occurrences of tags with NAME. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-by-name name (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-by-name name + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) "In TABLE, find all occurrences of tags matching REGEXP. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-by-name-regexp regexp (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-by-name-regexp regexp + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) "In TABLE, find all occurrences of tags matching PREFIX. Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." - (semantic-find-tags-for-completion prefix (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-for-completion prefix + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (cl-defmethod semanticdb-find-tags-by-class-method ((table semanticdb-abstract-table) class &optional tags) "In TABLE, find all occurrences of tags of CLASS. @@ -1329,8 +1335,12 @@ Returns a table of all matching tags." ;; `semantic-find-tags-included', which by default will just call ;; `semantic-find-tags-by-class'. (if (eq class 'include) - (semantic-find-tags-included (or tags (semanticdb-get-tags table))) - (semantic-find-tags-by-class class (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-included + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))) + (semantic-find-tags-by-class class + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (declare-function semantic-find-tags-external-children-of-type "semantic/find" (type &optional table)) @@ -1340,7 +1350,9 @@ Returns a table of all matching tags." Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." (require 'semantic/find) - (semantic-find-tags-external-children-of-type parent (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-external-children-of-type + parent (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) (declare-function semantic-find-tags-subclasses-of-type "semantic/find" (type &optional table)) @@ -1350,7 +1362,9 @@ Returns a table of all matching tags." Optional argument TAGS is a list of tags to search. Returns a table of all matching tags." (require 'semantic/find) - (semantic-find-tags-subclasses-of-type parent (or tags (semanticdb-get-tags table)))) + (semantic-find-tags-subclasses-of-type + parent (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table))))) ;;; Deep Searches (cl-defmethod semanticdb-deep-find-tags-by-name-method ((table semanticdb-abstract-table) name &optional tags) @@ -1359,7 +1373,10 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-by-name name (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-by-name + name (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (cl-defmethod semanticdb-deep-find-tags-by-name-regexp-method ((table semanticdb-abstract-table) regexp &optional tags) "In TABLE, find all occurrences of tags matching REGEXP. @@ -1367,7 +1384,10 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-by-name-regexp regexp (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-by-name-regexp + regexp (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (cl-defmethod semanticdb-deep-find-tags-for-completion-method ((table semanticdb-abstract-table) prefix &optional tags) "In TABLE, find all occurrences of tags matching PREFIX. @@ -1375,7 +1395,11 @@ Search in all tags in TABLE, and all components of top level tags in TABLE. Optional argument TAGS is a list of tags to search. Return a table of all matching tags." - (semantic-find-tags-for-completion prefix (semantic-flatten-tags-table (or tags (semanticdb-get-tags table))))) + (semantic-find-tags-for-completion + prefix + (semantic-flatten-tags-table + (or tags (and (slot-boundp table 'tags) + (semanticdb-get-tags table)))))) (provide 'semantic/db-find) commit 21f9be005318dcc58918884fc3c24d7d75562e96 Author: Spencer Baugh Date: Fri Apr 5 03:29:42 2024 +0300 (project-current): Fix the previous change * lisp/progmodes/project.el (project-current): Fix the previous change (bug#69584). diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index a10e24f3e28..da211566a3b 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -229,8 +229,8 @@ See the doc string of `project-find-functions' for the general form of the project instance object." (unless directory (setq directory (or project-current-directory-override default-directory))) - (let ((pr (project--find-in-directory directory)) - (non-essential (not maybe-prompt))) + (let* ((non-essential (not maybe-prompt)) + (pr (project--find-in-directory directory))) (cond (pr) ((unless project-current-directory-override commit b49765b516e921d7dc020f1038c1442b1bb420ef Author: Mattias Engdegård Date: Thu Apr 4 18:59:45 2024 +0200 ; * lisp/auth-source.el: add declarations to silence compiler diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 18670ed620b..a8bd9855720 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -2546,6 +2546,9 @@ Adapt also mode line." (when read-passwd-mode (read-passwd-toggle-visibility))) +(defvar overriding-text-conversion-style) +(declare-function set-text-conversion-style "textconv.c") + ;;;###autoload (defun read-passwd (prompt &optional confirm default) "Read a password, prompting with PROMPT, and return it. commit 4a74999a735d9c0980d119dedf266ac2035e3ae9 Author: Mattias Engdegård Date: Thu Apr 4 15:48:09 2024 +0200 ; * src/json.c: Comment correction diff --git a/src/json.c b/src/json.c index 702350b1b09..140c3625d4d 100644 --- a/src/json.c +++ b/src/json.c @@ -1055,7 +1055,7 @@ json_parse_string (struct json_parser *parser, bool intern, bool leading_colon) json_byte_workspace_reset (parser); if (leading_colon) json_byte_workspace_put (parser, ':'); - ptrdiff_t chars_delta = 0; /* nchars - nbytes */ + ptrdiff_t chars_delta = 0; /* nbytes - nchars */ for (;;) { /* This if is only here for a possible speedup. If there are 4 @@ -1105,7 +1105,7 @@ json_parse_string (struct json_parser *parser, bool intern, bool leading_colon) if (c & 0x80) { /* Parse UTF-8, strictly. This is the correct thing to do - whether or not the input is a unibyte or multibyte string. */ + whether the input is a unibyte or multibyte string. */ json_byte_workspace_put (parser, c); unsigned char c1 = json_input_get (parser); if ((c1 & 0xc0) != 0x80) commit c2e0ebf752cef595de16140933f51e810e0d4061 Author: Michael Albinus Date: Thu Apr 4 16:51:55 2024 +0200 Adapt treesitter tests for EMBA * test/infra/Makefile.in (TREE-SITTER-FILES): Add js-tests.el and python-tests.el, which don't follow test file name convention. * test/infra/test-jobs.yml: Regenerate. diff --git a/test/infra/Makefile.in b/test/infra/Makefile.in index 5ae32e7e005..20fa9021abc 100644 --- a/test/infra/Makefile.in +++ b/test/infra/Makefile.in @@ -108,8 +108,10 @@ endef $(foreach subdir, $(SUBDIRS), $(eval $(call subdir_template,$(subdir)))) +# js-tests.el and python-tests.el don't follow test file name convention. TREE-SITTER-FILES ?= $(shell cd .. ; \ - find lisp src \( -name "*-ts-mode-tests.el" -o -name "treesit-tests.el" \) | \ + find lisp src \( -name "*-ts-mode-tests.el" -o -name "treesit-tests.el" \ + -o -name "js-tests.el" -o -name "python-tests.el" \) | \ sort | sed s/\\.el/.log/) all: generate-test-jobs @@ -120,6 +122,7 @@ generate-test-jobs: $(FILE) $(SUBDIR_TARGETS) tree-sitter-files-template tree-sitter-files-template: @echo >>$(FILE) + @echo "# js-tests.el and python-tests.el don't follow test file name convention." >>$(FILE) @echo '.tree-sitter-files-template:' >>$(FILE) @echo ' variables:' >>$(FILE) @echo ' tree_sitter_files: >-' >>$(FILE) diff --git a/test/infra/test-jobs.yml b/test/infra/test-jobs.yml index 1f5d607eda4..095964ee4ed 100644 --- a/test/infra/test-jobs.yml +++ b/test/infra/test-jobs.yml @@ -572,6 +572,7 @@ test-src-inotify: target: emacs-inotify make_params: "-k -C test check-src" +# js-tests.el and python-tests.el don't follow test file name convention. .tree-sitter-files-template: variables: tree_sitter_files: >- @@ -580,7 +581,9 @@ test-src-inotify: lisp/progmodes/go-ts-mode-tests.log lisp/progmodes/heex-ts-mode-tests.log lisp/progmodes/java-ts-mode-tests.log + lisp/progmodes/js-tests.log lisp/progmodes/lua-ts-mode-tests.log + lisp/progmodes/python-tests.log lisp/progmodes/ruby-ts-mode-tests.log lisp/progmodes/typescript-ts-mode-tests.log src/treesit-tests.log commit 77022a0d7327d3a79de083997a11a727a371cade Author: Michael Albinus Date: Thu Apr 4 15:24:15 2024 +0200 ; * doc/misc/cl.texi (Function Bindings): Fix reference. diff --git a/doc/misc/cl.texi b/doc/misc/cl.texi index 65a29d955bc..a4a34ae07d6 100644 --- a/doc/misc/cl.texi +++ b/doc/misc/cl.texi @@ -1426,7 +1426,7 @@ the function bindings can be recursive. The scoping is lexical, but you can only capture functions in closures if @code{lexical-binding} is @code{t}. @xref{Closures,,,elisp,GNU Emacs Lisp Reference Manual}, and -@ref{Using Lexical Binding,,,elisp,GNU Emacs Lisp Reference Manual}. +@ref{Selecting Lisp Dialect,,,elisp,GNU Emacs Lisp Reference Manual}. Lexical scoping means that all references to the named functions must appear physically within the body of the commit 44d83def4fa046986ac6919ca53f789d01840ffa Author: Michael Albinus Date: Thu Apr 4 14:51:57 2024 +0200 Move read-passwd* to auth-source.el, avoiding compilation warnings * lisp/simple.el (read-passwd*): * lisp/subr.el (read-passwd*): Move definitions ... * lisp/auth-source.el: ... here. (icons): Require. diff --git a/lisp/auth-source.el b/lisp/auth-source.el index 5f5629d9cfc..18670ed620b 100644 --- a/lisp/auth-source.el +++ b/lisp/auth-source.el @@ -41,6 +41,7 @@ (require 'json) (require 'password-cache) +(require 'icons) (require 'cl-lib) (require 'eieio) @@ -2441,6 +2442,168 @@ point is moved into the passwords (see `authinfo-hide-elements'). (propertize "****" 'face 'font-lock-doc-face)) (overlay-put overlay 'display nil))) +;; It would be preferable to use "👁" ("\N{EYE}"). However, there is +;; no corresponding Unicode char with a slash. So we use symbols as +;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for +;; hiding the password. +(define-icon read-passwd--show-password-icon nil + '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) + (symbol "👁") + (text "")) + "Mode line icon to show a hidden password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + +(define-icon read-passwd--hide-password-icon nil + '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) + (symbol "⦵") + (text "<\\>")) + "Mode line icon to hide a visible password." + :group mode-line-faces + :version "30.1" + :help-echo "mouse-1: Toggle password visibility") + +(defvar read-passwd--mode-line-buffer nil + "Buffer to modify `mode-line-format' for showing/hiding passwords.") + +(defvar read-passwd--mode-line-icon nil + "Propertized mode line icon for showing/hiding passwords.") + +(defvar read-passwd--hide-password t + "Toggle whether password should be hidden in minubuffer.") + +(defun read-passwd--hide-password () + "Make password in minibuffer hidden or visible." + (let ((beg (minibuffer-prompt-end))) + (dotimes (i (1+ (- (buffer-size) beg))) + (if read-passwd--hide-password + (put-text-property + (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) + (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) + (put-text-property + (+ i beg) (+ 1 i beg) + 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) + +(defun read-passwd-toggle-visibility () + "Toggle minibuffer contents visibility. +Adapt also mode line." + (interactive) + (setq read-passwd--hide-password (not read-passwd--hide-password)) + (with-current-buffer read-passwd--mode-line-buffer + (setq read-passwd--mode-line-icon + `(:propertize + ,(if icon-preference + (icon-string + (if read-passwd--hide-password + 'read-passwd--show-password-icon + 'read-passwd--hide-password-icon)) + "") + mouse-face mode-line-highlight + local-map + (keymap + (mode-line keymap (mouse-1 . read-passwd-toggle-visibility))))) + (force-mode-line-update)) + (read-passwd--hide-password)) + +(defvar read-passwd-map + ;; BEWARE: `defconst' would purecopy it, breaking the sharing with + ;; minibuffer-local-map along the way! + (let ((map (make-sparse-keymap))) + (set-keymap-parent map minibuffer-local-map) + (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 + (define-key map "\t" #'read-passwd-toggle-visibility) + map) + "Keymap used while reading passwords.") + +(define-minor-mode read-passwd-mode + "Toggle visibility of password in minibuffer." + :group 'mode-line + :group 'minibuffer + :keymap read-passwd-map + :version "30.1" + + (setq read-passwd--hide-password nil + ;; Stolen from `eldoc-minibuffer-message'. + read-passwd--mode-line-buffer + (window-buffer + (or (window-in-direction 'above (minibuffer-window)) + (minibuffer-selected-window) + (get-largest-window)))) + + (if read-passwd-mode + (with-current-buffer read-passwd--mode-line-buffer + ;; Add `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format + (cons '(:eval read-passwd--mode-line-icon) + mode-line-format)))) + (with-current-buffer read-passwd--mode-line-buffer + ;; Remove `read-passwd--mode-line-icon'. + (when (listp mode-line-format) + (setq mode-line-format (cdr mode-line-format))))) + + (when read-passwd-mode + (read-passwd-toggle-visibility))) + +;;;###autoload +(defun read-passwd (prompt &optional confirm default) + "Read a password, prompting with PROMPT, and return it. +If optional CONFIRM is non-nil, read the password twice to make sure. +Optional DEFAULT is a default password to use instead of empty input. + +This function echoes `*' for each character that the user types. +You could let-bind `read-hide-char' to another hiding character, though. + +Once the caller uses the password, it can erase the password +by doing (clear-string STRING)." + (if confirm + (let (success) + (while (not success) + (let ((first (read-passwd prompt nil default)) + (second (read-passwd "Confirm password: " nil default))) + (if (equal first second) + (progn + (and (arrayp second) (not (eq first second)) (clear-string second)) + (setq success first)) + (and (arrayp first) (clear-string first)) + (and (arrayp second) (clear-string second)) + (message "Password not repeated accurately; please start over") + (sit-for 1)))) + success) + (let (minibuf) + (minibuffer-with-setup-hook + (lambda () + (setq minibuf (current-buffer)) + ;; Turn off electricity. + (setq-local post-self-insert-hook nil) + (setq-local buffer-undo-list t) + (setq-local select-active-regions nil) + (use-local-map read-passwd-map) + (setq-local inhibit-modification-hooks nil) ;bug#15501. + (setq-local show-paren-mode nil) ;bug#16091. + (setq-local inhibit--record-char t) + (read-passwd-mode 1) + (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) + (unwind-protect + (let ((enable-recursive-minibuffers t) + (read-hide-char (or read-hide-char ?*)) + (overriding-text-conversion-style 'password)) + (read-string prompt nil t default)) ; t = "no history" + (when (buffer-live-p minibuf) + (with-current-buffer minibuf + (read-passwd-mode -1) + ;; Not sure why but it seems that there might be cases where the + ;; minibuffer is not always properly reset later on, so undo + ;; whatever we've done here (bug#11392). + (remove-hook 'after-change-functions + #'read-passwd--hide-password 'local) + (kill-local-variable 'post-self-insert-hook) + ;; And of course, don't keep the sensitive data around. + (erase-buffer) + ;; Then restore the previous text conversion style. + (set-text-conversion-style text-conversion-style)))))))) + (provide 'auth-source) ;;; auth-source.el ends here diff --git a/lisp/simple.el b/lisp/simple.el index 0645f18cc78..e4629ce3db7 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -10862,86 +10862,6 @@ and setting it to nil." buffer-invisibility-spec) (setq buffer-invisibility-spec nil))) - -(defvar read-passwd--mode-line-buffer nil - "Buffer to modify `mode-line-format' for showing/hiding passwords.") - -(defvar read-passwd--mode-line-icon nil - "Propertized mode line icon for showing/hiding passwords.") - -(defun read-passwd-toggle-visibility () - "Toggle minibuffer contents visibility. -Adapt also mode line." - (interactive) - (setq read-passwd--hide-password (not read-passwd--hide-password)) - (with-current-buffer read-passwd--mode-line-buffer - (setq read-passwd--mode-line-icon - `(:propertize - ,(if icon-preference - (icon-string - (if read-passwd--hide-password - 'read-passwd--show-password-icon - 'read-passwd--hide-password-icon)) - "") - mouse-face mode-line-highlight - local-map - (keymap - (mode-line keymap (mouse-1 . read-passwd-toggle-visibility))))) - (force-mode-line-update)) - (read-passwd--hide-password)) - -(define-minor-mode read-passwd-mode - "Toggle visibility of password in minibuffer." - :group 'mode-line - :group 'minibuffer - :keymap read-passwd-map - :version "30.1" - - (require 'icons) - ;; It would be preferable to use "👁" ("\N{EYE}"). However, there is - ;; no corresponding Unicode char with a slash. So we use symbols as - ;; fallback only, with "⦵" ("\N{CIRCLE WITH HORIZONTAL BAR}") for - ;; hiding the password. - (define-icon read-passwd--show-password-icon nil - '((image "reveal.svg" "reveal.pbm" :height (0.8 . em)) - (symbol "👁") - (text "")) - "Mode line icon to show a hidden password." - :group mode-line-faces - :version "30.1" - :help-echo "mouse-1: Toggle password visibility") - (define-icon read-passwd--hide-password-icon nil - '((image "conceal.svg" "conceal.pbm" :height (0.8 . em)) - (symbol "⦵") - (text "<\\>")) - "Mode line icon to hide a visible password." - :group mode-line-faces - :version "30.1" - :help-echo "mouse-1: Toggle password visibility") - - (setq read-passwd--hide-password nil - ;; Stolen from `eldoc-minibuffer-message'. - read-passwd--mode-line-buffer - (window-buffer - (or (window-in-direction 'above (minibuffer-window)) - (minibuffer-selected-window) - (get-largest-window)))) - - (if read-passwd-mode - (with-current-buffer read-passwd--mode-line-buffer - ;; Add `read-passwd--mode-line-icon'. - (when (listp mode-line-format) - (setq mode-line-format - (cons '(:eval read-passwd--mode-line-icon) - mode-line-format)))) - (with-current-buffer read-passwd--mode-line-buffer - ;; Remove `read-passwd--mode-line-icon'. - (when (listp mode-line-format) - (setq mode-line-format (cdr mode-line-format))))) - - (when read-passwd-mode - (read-passwd-toggle-visibility))) - (defvar messages-buffer-mode-map (let ((map (make-sparse-keymap))) diff --git a/lisp/subr.el b/lisp/subr.el index 753c0144ca5..fba70342154 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -3381,92 +3381,6 @@ with Emacs. Do not call it directly in your own packages." t) (read-event))) -(defvar read-passwd-map - ;; BEWARE: `defconst' would purecopy it, breaking the sharing with - ;; minibuffer-local-map along the way! - (let ((map (make-sparse-keymap))) - (set-keymap-parent map minibuffer-local-map) - (define-key map "\C-u" #'delete-minibuffer-contents) ;bug#12570 - (define-key map "\t" #'read-passwd-toggle-visibility) - map) - "Keymap used while reading passwords.") - -(defvar read-passwd--hide-password t) - -(defun read-passwd--hide-password () - "Make password in minibuffer hidden or visible." - (let ((beg (minibuffer-prompt-end))) - (dotimes (i (1+ (- (buffer-size) beg))) - (if read-passwd--hide-password - (put-text-property - (+ i beg) (+ 1 i beg) 'display (string (or read-hide-char ?*))) - (remove-list-of-text-properties (+ i beg) (+ 1 i beg) '(display))) - (put-text-property - (+ i beg) (+ 1 i beg) - 'help-echo "C-u: Clear password\nTAB: Toggle password visibility")))) - -;; Actually in textconv.c. -(defvar overriding-text-conversion-style) -(declare-function set-text-conversion-style "textconv.c") - -(defun read-passwd (prompt &optional confirm default) - "Read a password, prompting with PROMPT, and return it. -If optional CONFIRM is non-nil, read the password twice to make sure. -Optional DEFAULT is a default password to use instead of empty input. - -This function echoes `*' for each character that the user types. -You could let-bind `read-hide-char' to another hiding character, though. - -Once the caller uses the password, it can erase the password -by doing (clear-string STRING)." - (if confirm - (let (success) - (while (not success) - (let ((first (read-passwd prompt nil default)) - (second (read-passwd "Confirm password: " nil default))) - (if (equal first second) - (progn - (and (arrayp second) (not (eq first second)) (clear-string second)) - (setq success first)) - (and (arrayp first) (clear-string first)) - (and (arrayp second) (clear-string second)) - (message "Password not repeated accurately; please start over") - (sit-for 1)))) - success) - (let (minibuf) - (minibuffer-with-setup-hook - (lambda () - (setq minibuf (current-buffer)) - ;; Turn off electricity. - (setq-local post-self-insert-hook nil) - (setq-local buffer-undo-list t) - (setq-local select-active-regions nil) - (use-local-map read-passwd-map) - (setq-local inhibit-modification-hooks nil) ;bug#15501. - (setq-local show-paren-mode nil) ;bug#16091. - (setq-local inhibit--record-char t) - (read-passwd-mode 1) - (add-hook 'post-command-hook #'read-passwd--hide-password nil t)) - (unwind-protect - (let ((enable-recursive-minibuffers t) - (read-hide-char (or read-hide-char ?*)) - (overriding-text-conversion-style 'password)) - (read-string prompt nil t default)) ; t = "no history" - (when (buffer-live-p minibuf) - (with-current-buffer minibuf - (read-passwd-mode -1) - ;; Not sure why but it seems that there might be cases where the - ;; minibuffer is not always properly reset later on, so undo - ;; whatever we've done here (bug#11392). - (remove-hook 'after-change-functions - #'read-passwd--hide-password 'local) - (kill-local-variable 'post-self-insert-hook) - ;; And of course, don't keep the sensitive data around. - (erase-buffer) - ;; Then restore the previous text conversion style. - (when (fboundp 'set-text-conversion-style) - (set-text-conversion-style text-conversion-style))))))))) - (defvar read-number-history nil "The default history for the `read-number' function.") commit a0d646fb9f3945d98586b15d157dbb909843f06c Author: Mattias Engdegård Date: Thu Apr 4 12:21:26 2024 +0200 * src/json.c (make_symset_table): Fix over-large allocation size. We multiplied when we should have added. Oops. diff --git a/src/json.c b/src/json.c index 33c3289b394..702350b1b09 100644 --- a/src/json.c +++ b/src/json.c @@ -143,7 +143,7 @@ make_symset_table (int bits, struct symset_tbl *up) int maxbits = min (SIZE_WIDTH - 2 - (word_size < 8 ? 2 : 3), 32); if (bits > maxbits) memory_full (PTRDIFF_MAX); /* Will never happen in practice. */ - struct symset_tbl *st = xnmalloc (sizeof *st->entries << bits, sizeof *st); + struct symset_tbl *st = xmalloc (sizeof *st + (sizeof *st->entries << bits)); st->up = up; ptrdiff_t size = symset_size (bits); for (ptrdiff_t i = 0; i < size; i++)