diff options
989 files changed, 35635 insertions, 24765 deletions
diff --git a/.gitignore b/.gitignore index 014970f96b2..890e63a4318 100644 --- a/.gitignore +++ b/.gitignore @@ -60,6 +60,7 @@ lib/execinfo.h lib/fcntl.h lib/getopt.h lib/getopt-cdefs.h +lib/gmp.h lib/ieee754.h lib/inttypes.h lib/libgnu.a @@ -135,6 +136,7 @@ src/gl-stamp *.o *.res *.so +*.dylib core core.*[0-9] gmon.out @@ -214,42 +214,6 @@ like 'apt-get build-dep emacs' (on older systems, replace 'emacs' with eg 'emacs25'). On Red Hat-based systems, the corresponding command is 'dnf builddep emacs' (on older systems, use 'yum-builddep' instead). -* GNU/Linux source and debug packages - -Many GNU/Linux systems provide separate packages containing the -sources and debug symbols of Emacs. They are useful if you want to -check the source code of Emacs primitive functions or debug Emacs on -the C level. - -The names of the packages that you need vary according to the -GNU/Linux distribution that you use. On Debian-based systems, you can -install a source package of Emacs with a command like 'apt-get source -emacs' (on older systems, replace 'emacs' with eg 'emacs25'). The -target directory for unpacking the source tree is the current -directory. On Red Hat-based systems, the corresponding command is -'dnf install emacs-debugsource', with target directory /usr/src/debug -(this requires to add the *-debuginfo repositories first, via 'dnf -config-manager --set-enabled fedora-debuginfo updates-debuginfo'). - -Once you have installed the source package, for example at -/path/to/emacs-26.1, add the following line to your startup file: - - (setq find-function-C-source-directory - "/path/to/emacs-26.1/src") - -The installation directory of the Emacs source package will contain -the exact package name and version number Emacs is installed on your -system. If a new Emacs package is installed, the source package must -be reinstalled as well, and the setting in your startup file must be -updated. - -Emacs debugging symbols are distributed by a debug package. It does -not exist for every released Emacs package, this depends on the -distribution. On Debian-based systems, you can install a debug -package of Emacs with a command like 'apt-get install emacs-dbg' (on -older systems, replace 'emacs' with eg 'emacs25'). On Red Hat-based -systems, the corresponding command is 'dnf debuginfo-install emacs'. - DETAILED BUILDING AND INSTALLATION: @@ -2,7 +2,7 @@ Copyright (C) 2001-2020 Free Software Foundation, Inc. See the end of the file for license conditions. -This directory tree holds version 27.1 of GNU Emacs, the extensible, +This directory tree holds version 28.0.50 of GNU Emacs, the extensible, customizable, self-documenting real-time display editor. The file INSTALL in this directory says how to build and install GNU diff --git a/admin/CPP-DEFINES b/admin/CPP-DEFINES index ea99d50094f..ce9a44436d8 100644 --- a/admin/CPP-DEFINES +++ b/admin/CPP-DEFINES @@ -201,7 +201,6 @@ HAVE_LIBXML2 HAVE_LIBXMU HAVE_LOCALTIME_R HAVE_LOCAL_SOCKETS -HAVE_LONG_LONG_INT HAVE_LRAND48 HAVE_LSTAT HAVE_LUTIMES @@ -322,7 +321,6 @@ HAVE_TM_ZONE HAVE_TOUCHLOCK HAVE_TZNAME HAVE_TZSET -HAVE_UNSIGNED_LONG_LONG_INT HAVE_UTIL_H HAVE_UTIMENSAT HAVE_UTIMES diff --git a/admin/authors.el b/admin/authors.el index acaa7dfaa77..1c069173c85 100644 --- a/admin/authors.el +++ b/admin/authors.el @@ -285,9 +285,9 @@ If REALNAME is nil, ignore that author.") (defvar authors-obsolete-files-regexps - '(".*loaddefs\\.el$" ; not obsolete, but auto-generated - "\\.\\(bzr\\|cvs\\|git\\)ignore$" ; obsolete or uninteresting - "\\.arch-inventory$" + '(".*loaddefs\\.el\\'" ; not obsolete, but auto-generated + "\\.\\(bzr\\|cvs\\|git\\)ignore\\'" ; obsolete or uninteresting + "\\.arch-inventory\\'" "ChangeLog\\(\\.[0-9]+\\)?\\'" "\\(automated\\|test\\)/data/" ; not interesting "cedet/tests/" @@ -367,7 +367,7 @@ Changes to files matching one of the regexps in this list are not listed.") "lib/stdarg.in.h" "lib/stdbool.in.h" "unidata/bidimirror.awk" "unidata/biditype.awk" "split-man" "Xkeymap.txt" "ms-7bkermit" "ulimit.hack" - "gnu-hp300" "refcard.bit" "ledit.l" "forms.README" "forms-d2.dat" + "gnu-hp300" "refcard.bit" "forms.README" "forms-d2.dat" "CXTERM-DIC/PY.tit" "CXTERM-DIC/ZIRANMA.tit" "CXTERM-DIC/CTLau.tit" "CXTERM-DIC/CTLauB.tit" "copying.paper" "celibacy.1" "condom.1" "echo.msg" "sex.6" @@ -475,6 +475,9 @@ Changes to files matching one of the regexps in this list are not listed.") ;; Replaced by lisp/thread.el "lisp/emacs-lisp/thread-list.el" "etc/images/slash.bmp" + "src/mini-gmp-emacs.c" + "lib/dosname.h" + "lib/putenv.c" ) "List of files and directories to ignore. Changes to files in this list are not listed.") @@ -611,7 +614,7 @@ Changes to files in this list are not listed.") ;; No longer distributed: lselect.el. ("Lucid, Inc." :changed "bytecode.c" "byte-opt.el" "byte-run.el" "bytecomp.el" "delsel.el" "disass.el" "faces.el" "font-lock.el" - "lmenu.el" "mailabbrev.el" "select.el" "xfaces.c" "xselect.c") + "mailabbrev.el" "select.el" "xfaces.c" "xselect.c") ;; MCC. No longer distributed: emacsserver.c. ("Microelectronics and Computer Technology Corporation" :changed "etags.c" "emacsclient.c" "movemail.c" @@ -775,7 +778,7 @@ Changes to files in this list are not listed.") "erc-hecomplete.el" "eshell/esh-maint.el" "language/persian.el" - "ledit.el" "meese.el" "iswitchb.el" "longlines.el" + "meese.el" "iswitchb.el" "longlines.el" "mh-exec.el" "mh-init.el" "mh-customize.el" "net/zone-mode.el" "xesam.el" "term/mac-win.el" "sup-mouse.el" @@ -879,7 +882,9 @@ Changes to files in this list are not listed.") "library-of-babel.org" "flymake-elisp.el" "flymake-ui.el" - "pinentry.el") + "pinentry.el" + "ledit.el" + "lmenu.el") "File names which are valid, but no longer exist (or cannot be found) in the repository.") @@ -1121,6 +1126,8 @@ in the repository.") ("gnus-news.texi" . "doc/misc/gnus.texi") ("lisp/multifile.el". "lisp/fileloop.el") ("lisp/emacs-lisp/thread.el". "lisp/thread.el") + ("src/mini-gmp.c" . "lib/mini-gmp.c") + ("src/mini-gmp.h" . "lib/mini-gmp.h") ) "Alist of files which have been renamed during their lifetime. Elements are (OLDNAME . NEWNAME).") @@ -1142,7 +1149,7 @@ Elements are (OLDNAME . NEWNAME).") \\(\\(cs\\|fr\\|sk\\)-\\)?survival\\)\\.tex\\'" "refcards/\\&") ("\\`refcard-\\(de\\|pl\\)\\.tex\\'" "refcards/\\1-refcard.tex") ("\\`\\(refcards/\\)?fr-drdref\\.tex\\'" "refcards/fr-dired-ref.tex") - ("^\\(TUTORIAL[^/]*\\)" "tutorials/\\1") + ("\\`\\(TUTORIAL[^/]*\\)" "tutorials/\\1") ("\\`themes/dev-\\(tsdh-\\(?:light\\|dark\\)-theme\\.el\\)\\'" "themes/\\1") ;; Moved from lisp/toolbar to etc/images. @@ -1167,9 +1174,9 @@ remove\\|run\\|until\\|up\\|watch\\)\\(\\.\\(?:pb\\|xp\\)m\\)\\'" ("\\`\\(toolbar/gud-\\|images/gud/\\)s\\(i\\)?\\(\\.\\(?:pb\\|xp\\)m\\)\\'" "images/gud/step\\2\\3") ("\\`toolbar/lc-\\([-a-z]+\\.xpm\\)\\'" "images/low-color/\\1") - ("^\\(tree-widget/\\(?:default\\|folder\\)/[-a-z]+\\.\\(png\\|xpm\\)\\)$" + ("\\`\\(tree-widget/\\(?:default\\|folder\\)/[-a-z]+\\.\\(png\\|xpm\\)\\)\\'" "images/\\1") - ("^\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" + ("\\`\\(images/icons/\\)mac\\(emacs\\)_\\([0-9]+\\)\\(\\.png\\)" "\\1\\2\\3_mac\\4") ("\\(images/icons/\\)emacs_\\([0-9][0-9]\\)\\.png" "\\1hicolor/\\2x\\2/apps/emacs.png") @@ -1200,10 +1207,10 @@ ediff\\|emerge\\|log-edit\\|log-view\\|pcvs\\|smerge-mode\\|vc\\)\\.el\\'" ;; Maybe not the exact new name, but disambiguates from lisp/. ("automated/\\([^/]*\\)\\.el\\'" "\\1-tests.el") ;; NB lax rules should come last. - ("^m/m-\\(.*\\.h\\)$" "m/\\1" t) - ("^m-\\(.*\\.h\\)$" "\\1" t) - ("^s/s-\\(.*\\.h\\)$" "s/\\1" t) - ("^s-\\(.*\\.h\\)$" "\\1" t) + ("\\`m/m-\\(.*\\.h\\)\\'" "m/\\1" t) + ("\\`m-\\(.*\\.h\\)\\'" "\\1" t) + ("\\`s/s-\\(.*\\.h\\)\\'" "s/\\1" t) + ("\\`s-\\(.*\\.h\\)\\'" "\\1" t) ("\\.\\(el\\|[ch]\\|x[pb]m\\|pbm\\)\\'" t t) ) "List of regexps and rewriting rules for renamed files. diff --git a/admin/charsets/cp51932.awk b/admin/charsets/cp51932.awk index 6aac98815b5..c3555095249 100644 --- a/admin/charsets/cp51932.awk +++ b/admin/charsets/cp51932.awk @@ -43,13 +43,14 @@ BEGIN { END { print ")))"; - print " (mapc #'(lambda (x)"; - print " (setcar x (decode-char 'japanese-jisx0208 (car x))))"; - print " map)"; + print " (setq map (mapcar (lambda (x)"; + print " (cons (decode-char 'japanese-jisx0208 (car x))"; + print " (cdr x)))"; + print " map))"; print " (define-translation-table 'cp51932-decode map)"; - print " (mapc #'(lambda (x)"; - print " (let ((tmp (car x)))"; - print " (setcar x (cdr x)) (setcdr x tmp)))"; + print " (mapc (lambda (x)"; + print " (let ((tmp (car x)))"; + print " (setcar x (cdr x)) (setcdr x tmp)))"; print " map)"; print " (define-translation-table 'cp51932-encode map))"; print ""; diff --git a/admin/charsets/eucjp-ms.awk b/admin/charsets/eucjp-ms.awk index 0c9f94d0f48..f6a6748ce51 100644 --- a/admin/charsets/eucjp-ms.awk +++ b/admin/charsets/eucjp-ms.awk @@ -93,15 +93,17 @@ function write_entry (unicode) { END { print ")))"; - print " (mapc #'(lambda (x)"; + print " (setq map"; + print " (mapcar"; + print " (lambda (x)"; print " (let ((code (logand (car x) #x7F7F)))"; print " (if (integerp (cdr x))"; - print " (setcar x (decode-char 'japanese-jisx0208 code))"; - print " (setcar x (decode-char 'japanese-jisx0212 code))"; - print " (setcdr x (cadr x)))))"; - print " map)"; + print " (cons (decode-char 'japanese-jisx0208 code) (cdr x))"; + print " (cons (decode-char 'japanese-jisx0212 code)" + print " (cadr x)))))"; + print " map))"; print " (define-translation-table 'eucjp-ms-decode map)"; - print " (mapc #'(lambda (x)"; + print " (mapc (lambda (x)"; print " (let ((tmp (car x)))"; print " (setcar x (cdr x)) (setcdr x tmp)))"; print " map)"; diff --git a/admin/gitmerge.el b/admin/gitmerge.el index eeef4e3fc59..922ddef6bbd 100644 --- a/admin/gitmerge.el +++ b/admin/gitmerge.el @@ -52,7 +52,7 @@ ;; caused false positives. --Stef (let ((skip "back[- ]?port\\|cherry picked from commit\\|\ \\(do\\( no\\|n['’]\\)t\\|no need to\\) merge\\|not to be merged\\|\ -bump \\(Emacs \\)?version\\|Auto-commit")) +bump Emacs version\\|Auto-commit")) (if noninteractive skip ;; "Regenerate" is quite prone to false positives. ;; We only want to skip merging things like AUTHORS and ldefs-boot. diff --git a/admin/merge-gnulib b/admin/merge-gnulib index 3dee0b72b32..3f32536a629 100755 --- a/admin/merge-gnulib +++ b/admin/merge-gnulib @@ -31,19 +31,19 @@ GNULIB_MODULES=' careadlinkat close-stream copy-file-range count-leading-zeros count-one-bits count-trailing-zeros crypto/md5-buffer crypto/sha1-buffer crypto/sha256-buffer crypto/sha512-buffer - d-type diffseq dosname double-slash-root dtoastr dtotimespec dup2 + d-type diffseq double-slash-root dtoastr dtotimespec dup2 environ execinfo explicit_bzero faccessat - fcntl fcntl-h fdopendir - filemode filevercmp flexmember fpieee fstatat fsusage fsync - getloadavg getopt-gnu gettime gettimeofday gitlog-to-changelog - ieee754-h ignore-value intprops largefile lstat + fchmodat fcntl fcntl-h fdopendir + filemode filename filevercmp flexmember fpieee fstatat fsusage fsync futimens + getloadavg getopt-gnu getrandom gettime gettimeofday gitlog-to-changelog + ieee754-h ignore-value intprops largefile libgmp lstat manywarnings memmem-simple mempcpy memrchr minmax mkostemp mktime nstrftime - pathmax pipe2 pselect pthread_sigmask putenv + pathmax pipe2 pselect pthread_sigmask qcopy-acl readlink readlinkat regex sig2str socklen stat-time std-gnu11 stdalign stddef stdio stpcpy strnlen strtoimax symlink sys_stat sys_time tempname time time_r time_rz timegm timer-time timespec-add timespec-sub - update-copyright unlocked-io utimens + update-copyright unlocked-io utimensat vla warnings ' diff --git a/admin/notes/git-workflow b/admin/notes/git-workflow index 28b6f91a25d..d109cdaa354 100644 --- a/admin/notes/git-workflow +++ b/admin/notes/git-workflow @@ -15,14 +15,15 @@ Initial setup ============= Then we want to clone the repository. We normally want to have both -the current master and the emacs-26 branch. +the current master and (if there is one) the active release branch +(eg emacs-27). mkdir ~/emacs cd ~/emacs git clone <membername>@git.sv.gnu.org:/srv/git/emacs.git master cd master git config push.default current -git worktree add ../emacs-26 emacs-26 +git worktree add ../emacs-27 emacs-27 You now have both branches conveniently accessible, and you can do "git pull" in them once in a while to keep updated. @@ -52,11 +53,11 @@ you commit your change locally and then send a patch file as a bug report as described in ../../CONTRIBUTE. -Backporting to emacs-26 -======================= +Backporting to release branch +============================= If you have applied a fix to the master, but then decide that it should -be applied to the emacs-26 branch, too, then +be applied to the release branch, too, then cd ~/emacs/master git log @@ -66,7 +67,7 @@ which will look like commit 958b768a6534ae6e77a8547a56fc31b46b63710b -cd ~/emacs/emacs-26 +cd ~/emacs/emacs-27 git cherry-pick -xe 958b768a6534ae6e77a8547a56fc31b46b63710b and add "Backport:" to the commit string. Then @@ -74,17 +75,28 @@ and add "Backport:" to the commit string. Then git push -Merging emacs-26 to the master -============================== +Reverting on release branch +=========================== + +If a commit is made to the release branch, and then it is later +decided that this change should only be on the master branch, the +simplest way to handle this is to revert the commit on the release +branch, and include in the associated log entry "do not merge to master". +(Otherwise, the reversion may get merged to master, and inadvertently +clobber the change on master if it has been manually made there.) + + +Merging release branch to the master +==================================== It is recommended to use the file gitmerge.el in the admin directory -for merging 'emacs-26' into 'master'. It will take care of many +for merging the release branch into 'master'. It will take care of many things which would otherwise have to be done manually, like ignoring commits that should not land in master, fixing up ChangeLogs and automatically dealing with certain types of conflicts. If you really want to, you can do the merge manually, but then you're on your own. If you still choose to do that, make absolutely sure that you *always* -use the 'merge' command to transport commits from 'emacs-26' to +use the 'merge' command to transport commits from the release branch to 'master'. *Never* use 'cherry-pick'! If you don't know why, then you shouldn't manually do the merge in the first place; just use gitmerge.el instead. @@ -97,11 +109,11 @@ up-to-date by doing a pull. Then start Emacs with emacs -l admin/gitmerge.el -f gitmerge You'll be asked for the branch to merge, which will default to -'origin/emacs-26', which you should accept. Merging a local tracking +(eg) 'origin/emacs-27', which you should accept. Merging a local tracking branch is discouraged, since it might not be up-to-date, or worse, contain commits from you which are not yet pushed upstream. -You will now see the list of commits from 'emacs-26' which are not yet +You will now see the list of commits from the release branch that are not yet merged to 'master'. You might also see commits that are already marked for "skipping", which means that they will be merged with a different merge strategy ('ours'), which will effectively ignore the diff --git a/admin/notes/unicode b/admin/notes/unicode index 6cb1b764c51..1e418590a68 100644 --- a/admin/notes/unicode +++ b/admin/notes/unicode @@ -256,11 +256,19 @@ nontrivial changes to the build process. etc/tutorials/TUTORIAL.ja + * iso-2022-7bit + + This file contains multiple Chinese charsets, and converting it + to UTF-8 would lose the charset property and would change the + code's behavior. Although this could be worked around by + propertizing the strings, that hasn't been done. + + lisp/international/titdic-cnv.el + * utf-8-emacs These files contain characters that cannot be encoded in UTF-8. - lisp/international/titdic-cnv.el lisp/language/ethio-util.el lisp/language/ethiopic.el lisp/language/ind-util.el diff --git a/admin/nt/dist-build/README-windows-binaries b/admin/nt/dist-build/README-windows-binaries index c8fb5797de9..01f7ed9da13 100644 --- a/admin/nt/dist-build/README-windows-binaries +++ b/admin/nt/dist-build/README-windows-binaries @@ -67,11 +67,11 @@ The dependencies. Unzipping this file on top of emacs-$VERSION-x86_64-no-deps.zip should result in the same install as emacs-$VERSION-x86_64.zip. -emacs-27-i686-deps.zip +emacs-$VERSION-i686-deps.zip The 32-bit version of the dependencies. -emacs-27-deps-mingw-w64-src.zip +emacs-$VERSION-deps-mingw-w64-src.zip The source for the dependencies. Source for Emacs itself is available in the main distribution tarball. These dependencies were produced diff --git a/admin/nt/dist-build/build-dep-zips.py b/admin/nt/dist-build/build-dep-zips.py index 0e5f1ae1dc6..7047d28346d 100755 --- a/admin/nt/dist-build/build-dep-zips.py +++ b/admin/nt/dist-build/build-dep-zips.py @@ -26,7 +26,7 @@ import re from subprocess import check_output ## Constants -EMACS_MAJOR_VERSION="27" +EMACS_MAJOR_VERSION="28" # This list derives from the features we want Emacs to compile with. PKG_REQ='''mingw-w64-x86_64-giflib diff --git a/admin/release-process b/admin/release-process index b3dfad58729..1ed7a2e29e7 100644 --- a/admin/release-process +++ b/admin/release-process @@ -197,16 +197,11 @@ and change key bindings where necessary. The current list of modes: 2. Minibuffer binds 'M-s' to 'next-matching-history-element' (not useful any more since C-s can now search in the history). -3. 'center-line' in Text mode was already moved to the text formatting - keymap as 'M-o M-s' (thus this binding is not necessary any more - in 'nroff-mode-map' too and can be removed now from the nroff mode - because it can now use the global key binding 'M-o M-s' 'center-line'). - -4. PCL-CVS binds 'M-s' to 'cvs-status', and log-edit-mode binds it to +3. PCL-CVS binds 'M-s' to 'cvs-status', and log-edit-mode binds it to 'log-edit-comment-search-forward'. Perhaps search commands on the global key binding 'M-s' are useless in these modes. -5. Rmail binds '\es' to 'rmail-search'/'rmail-summary-search'. +4. Rmail binds '\es' to 'rmail-search'/'rmail-summary-search'. * DOCUMENTATION diff --git a/admin/unidata/unidata-gen.el b/admin/unidata/unidata-gen.el index 71959d633c5..73453cb9e47 100644 --- a/admin/unidata/unidata-gen.el +++ b/admin/unidata/unidata-gen.el @@ -1,4 +1,4 @@ -;; unidata-gen.el -- Create files containing character property data. +;; unidata-gen.el -- Create files containing character property data -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -349,13 +349,10 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (n o c))))) ;; Functions to access the above data. -(defsubst unidata-prop-prop (proplist) (nth 0 proplist)) -(defsubst unidata-prop-index (proplist) (nth 1 proplist)) -(defsubst unidata-prop-generator (proplist) (nth 2 proplist)) -(defsubst unidata-prop-docstring (proplist) (nth 3 proplist)) -(defsubst unidata-prop-describer (proplist) (nth 4 proplist)) -(defsubst unidata-prop-default (proplist) (nth 5 proplist)) -(defsubst unidata-prop-val-list (proplist) (nth 6 proplist)) +(cl-defstruct (unidata-prop + (:type list) + (:constructor nil)) + prop index generator docstring describer default val-list) ;; SIMPLE TABLE @@ -383,11 +380,11 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." ;; 3rd: 0 (corresponding to uniprop_encode_character in chartab.c) ;; 4th to 5th: nil -(defun unidata-gen-table-character (prop prop-idx &rest ignore) +(defun unidata-gen-table-character (prop prop-idx &rest _ignore) (let ((table (make-char-table 'char-code-property-table)) (vec (make-vector 128 0)) (tail unidata-list) - elt range val idx slot) + elt range val) (if (functionp prop-idx) (setq tail (funcall prop-idx) prop-idx 1)) @@ -395,9 +392,9 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (setq elt (car tail) tail (cdr tail)) (setq range (car elt) val (nth prop-idx elt)) - (if (= (length val) 0) - (setq val nil) - (setq val (string-to-number val 16))) + (setq val (if (= (length val) 0) + nil + (string-to-number val 16))) (if (consp range) (if val (set-char-table-range table range val)) @@ -419,8 +416,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (setq first-index last-index))) (setq tail (cdr tail))) (when first-index - (let ((str (string 1 first-index)) - c) + (let ((str (string 1 first-index))) (while (<= first-index last-index) (setq str (format "%s%c" str (or (aref vec first-index) 0)) first-index (1+ first-index))) @@ -502,7 +498,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." ;; bidi.c:bidi_get_type and bidi.c:bidi_get_category. (bidi-warning "\ ** Found new bidi-class `%s', please update bidi.c and dispextern.h") - tail elt range val val-code idx slot + tail elt range val val-code prev-range-data) (setq val-list (cons nil (copy-sequence val-list))) (setq tail val-list val-code 0) @@ -510,9 +506,9 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (while tail (setcar tail (cons (car tail) val-code)) (setq tail (cdr tail) val-code (1+ val-code))) - (if (consp default-value) - (setq default-value (copy-sequence default-value)) - (setq default-value (list default-value))) + (setq default-value (if (consp default-value) + (copy-sequence default-value) + (list default-value))) (setcar default-value (unidata-encode-val val-list (car default-value))) (set-char-table-range table t (car default-value)) @@ -602,17 +598,17 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (if (= count 128) (if val (set-char-table-range table (cons start limit) val-code)) - (if (= val-code 0) - (set-char-table-range table (cons start limit) str) - (if (> count 2) - (setq str (concat str (string val-code (+ count 128)))) - (if (= count 2) - (setq str (concat str (string val-code val-code))) - (setq str (concat str (string val-code))))) - (set-char-table-range table (cons start limit) str)))))) + (set-char-table-range table (cons start limit) + (if (= val-code 0) + str + (concat str (if (> count 2) + (string val-code (+ count 128)) + (if (= count 2) + (string val-code val-code) + (string val-code)))))))))) (set-char-table-extra-slot table 0 prop) - (set-char-table-extra-slot table 4 (vconcat (mapcar 'car val-list))) + (set-char-table-extra-slot table 4 (vconcat (mapcar #'car val-list))) table)) (defun unidata-gen-table-symbol (prop index default-value val-list) @@ -679,8 +675,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (let ((beg 0) (end 0) (len1 (length l1)) - (len2 (length l2)) - result) + (len2 (length l2))) (when (< len1 16) (while (and l1 (eq (car l1) (car l2))) (setq beg (1+ beg) @@ -688,13 +683,13 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (while (and (< end len1) (< end len2) (eq (nth (- len1 end 1) l1) (nth (- len2 end 1) l2))) (setq end (1+ end)))) - (if (= (+ beg end) 0) - (setq result (list -1)) - (setq result (list (+ (* beg 16) (+ beg (- len1 end)))))) - (while (< end len2) - (setcdr result (cons (nth (- len2 end 1) l2) (cdr result))) - (setq end (1+ end))) - result)) + (let ((result (list (if (= (+ beg end) 0) + -1 + (+ (* beg 16) (+ beg (- len1 end))))))) + (while (< end len2) + (push (nth (- len2 end 1) l2) (cdr result)) + (setq end (1+ end))) + result))) ;; Return a compressed form of the vector VEC. Each element of VEC is ;; a list of symbols of which names can be concatenated to form a @@ -703,7 +698,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." ;; elements is usually small. (defun unidata-word-list-compress (vec) - (let (last-elt last-idx diff-head tail elt val) + (let (last-elt last-idx diff-head elt val) (dotimes (i 128) (setq elt (aref vec i)) (when elt @@ -768,7 +763,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (vec (make-vector 128 nil)) (idx 0) (case-fold-search nil) - c word-list tail-list last-list word diff-head) + c word-list tail-list last-list diff-head) (while (< i len) (setq c (aref val i)) (if (< c 3) @@ -784,7 +779,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (setq diff-head (prog1 (aref val i) (setq i (1+ i))))) (setq tail-list (nthcdr (% diff-head 16) last-list)) - (dotimes (i (/ diff-head 16)) + (dotimes (_ (/ diff-head 16)) (setq word-list (nconc word-list (list (car l))) l (cdr l)))))) (setq word-list @@ -808,7 +803,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (setcdr tail (cons elt (cdr tail))) (setcar tail " "))) (setq tail (cddr tail))) - (setq name (apply 'concat name)))) + (setq name (apply #'concat name)))) (aset table c name) (if (= c char) (setq val name)))) @@ -872,7 +867,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (vec (make-vector 128 nil)) (idx 0) (case-fold-search nil) - c word-list tail-list last-list word diff-head) + c word-list tail-list last-list diff-head) (while (< i len) (setq c (aref val i)) (if (< c 3) @@ -888,7 +883,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (setq diff-head (prog1 (aref val i) (setq i (1+ i))))) (setq tail-list (nthcdr (% diff-head 16) last-list)) - (dotimes (i (/ diff-head 16)) + (dotimes (_ (/ diff-head 16)) (setq word-list (nconc word-list (list (car l))) l (cdr l)))))) (setq word-list @@ -945,7 +940,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (word-list (list nil)) word-table block-list block-word-table block-end - tail elt range val idx slot) + tail elt range val idx) (setq tail unidata-list) (setq block-end -1) (while tail @@ -984,9 +979,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (push (list val range) block-list)))) (let* ((start (ash (ash range -7) 7)) (limit (+ start 127)) - (first tail) - (vec (make-vector 128 nil)) - c name len) + (vec (make-vector 128 nil))) (if (<= start block-end) ;; START overlap with the previous block. (aset table range (nth prop-idx elt)) @@ -1037,10 +1030,10 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (cdr (assq elt word-list)))) (setcar tail (string code)) (setq tail (cdr tail))) - (aset vec i (mapconcat 'identity (aref vec i) ""))))) + (aset vec i (mapconcat #'identity (aref vec i) ""))))) (set-char-table-range table (cons idx (+ idx 127)) - (mapconcat 'identity vec ""))))) + (mapconcat #'identity vec ""))))) (setq block-word-table (make-vector (length block-list) nil)) (setq idx 0) @@ -1086,19 +1079,18 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (or (byte-code-function-p (symbol-function fun)) (byte-compile fun)))) -(defun unidata-gen-table-name (prop index &rest ignore) +(defun unidata-gen-table-name (prop index &rest _ignore) (let* ((table (unidata-gen-table-word-list prop index 'unidata-split-name)) (word-tables (char-table-extra-slot table 4))) (unidata--ensure-compiled 'unidata-get-name 'unidata-put-name) (set-char-table-extra-slot table 1 (symbol-function 'unidata-get-name)) (set-char-table-extra-slot table 2 (symbol-function 'unidata-put-name)) - (if (eq prop 'name) - (set-char-table-extra-slot table 4 + (set-char-table-extra-slot table 4 + (if (eq prop 'name) (vector (car word-tables) (cdr word-tables) - unidata-name-jamo-name-table)) - (set-char-table-extra-slot table 4 + unidata-name-jamo-name-table) (vector (car word-tables)))) table)) @@ -1107,24 +1099,25 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." str (let ((len (length str)) (l nil) - (idx 0) - c) + (idx 0)) (if (= len 0) nil (dotimes (i len) - (setq c (aref str i)) - (if (= c 32) - (setq l (if (= (aref str idx) ?<) - (cons (intern (substring str (1+ idx) (1- i))) l) - (cons (string-to-number (substring str idx i) 16) l)) - idx (1+ i)))) - (if (= (aref str idx) ?<) - (setq l (cons (intern (substring str (1+ idx) (1- len))) l)) - (setq l (cons (string-to-number (substring str idx len) 16) l))) + (let ((c (aref str i))) + (when (= c ?\s) + (push (if (= (aref str idx) ?<) + (intern (substring str (1+ idx) (1- i))) + (string-to-number (substring str idx i) 16)) + l) + (setq idx (1+ i))))) + (push (if (= (aref str idx) ?<) + (intern (substring str (1+ idx) (1- len))) + (string-to-number (substring str idx len) 16)) + l) (nreverse l))))) -(defun unidata-gen-table-decomposition (prop index &rest ignore) +(defun unidata-gen-table-decomposition (prop index &rest _ignore) (let* ((table (unidata-gen-table-word-list prop index 'unidata-split-decomposition)) (word-tables (char-table-extra-slot table 4))) (unidata--ensure-compiled 'unidata-get-decomposition @@ -1167,7 +1160,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (forward-line))) result)) -(defun unidata-gen-table-special-casing (prop prop-idx &rest ignore) +(defun unidata-gen-table-special-casing (prop prop-idx &rest _ignore) (let ((table (make-char-table 'char-code-property-table))) (set-char-table-extra-slot table 0 prop) (mapc (lambda (entry) @@ -1175,7 +1168,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." ;; If character maps to a single character, the mapping is already ;; covered by regular casing property. Don’t store those. (when (/= (length v) 1) - (set-char-table-range table ch (apply 'string v))))) + (set-char-table-range table ch (apply #'string v))))) (or unidata-gen-table-special-casing--cache (setq unidata-gen-table-special-casing--cache (unidata-gen-table-special-casing--do-load)))) @@ -1353,7 +1346,7 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." ;; unidata-gen-table-special-casing--do-load and there is no other file ;; to compare those values with. This is why we’re skipping the check ;; for special casing properties. - (unless (eq generator 'unidata-gen-table-special-casing) + (unless (eq generator #'unidata-gen-table-special-casing) (setq table (progn (message "Generating %S table..." prop) (funcall generator prop index default-value val-list)) @@ -1369,19 +1362,21 @@ Property value is a symbol `o' (Open), `c' (Close), or `n' (None)." (and (stringp val1) (= (length val1) 0) (setq val1 nil)) - (if val1 - (cond ((eq generator 'unidata-gen-table-symbol) - (setq val1 (intern val1))) - ((eq generator 'unidata-gen-table-integer) - (setq val1 (string-to-number val1))) - ((eq generator 'unidata-gen-table-character) - (setq val1 (string-to-number val1 16))) - ((eq generator 'unidata-gen-table-decomposition) - (setq val1 (unidata-split-decomposition val1)))) - (cond ((eq prop 'decomposition) - (setq val1 (list char))) - ((eq prop 'bracket-type) - (setq val1 'n)))) + (setq val1 + (if val1 + (cond ((eq generator #'unidata-gen-table-symbol) + (intern val1)) + ((eq generator #'unidata-gen-table-integer) + (string-to-number val1)) + ((eq generator #'unidata-gen-table-character) + (string-to-number val1 16)) + ((eq generator #'unidata-gen-table-decomposition) + (unidata-split-decomposition val1)) + (t val1)) + (cond ((eq prop 'decomposition) + (list char)) + ((eq prop 'bracket-type) + 'n)))) (setq val2 (aref table char)) (when decoder (setq val2 (funcall decoder char val2 table))) diff --git a/build-aux/config.guess b/build-aux/config.guess index 4c8498faf3e..92bfc33e296 100755 --- a/build-aux/config.guess +++ b/build-aux/config.guess @@ -2,7 +2,7 @@ # Attempt to guess a canonical system name. # Copyright 1992-2020 Free Software Foundation, Inc. -timestamp='2019-09-10' +timestamp='2020-04-26' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -50,7 +50,7 @@ version="\ GNU config.guess ($timestamp) Originally written by Per Bothner. -Copyright 1992-2019 Free Software Foundation, Inc. +Copyright 1992-2020 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -99,6 +99,8 @@ tmp= trap 'test -z "$tmp" || rm -fr "$tmp"' 0 1 2 13 15 set_cc_for_build() { + # prevent multiple calls if $tmp is already set + test "$tmp" && return 0 : "${TMPDIR=/tmp}" # shellcheck disable=SC2039 { tmp=`(umask 077 && mktemp -d "$TMPDIR/cgXXXXXX") 2>/dev/null` && test -n "$tmp" && test -d "$tmp" ; } || @@ -924,7 +926,7 @@ EOF echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" exit ;; alpha:Linux:*:*) - case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' < /proc/cpuinfo` in + case `sed -n '/^cpu model/s/^.*: \(.*\)/\1/p' /proc/cpuinfo 2>/dev/null` in EV5) UNAME_MACHINE=alphaev5 ;; EV56) UNAME_MACHINE=alphaev56 ;; PCA56) UNAME_MACHINE=alphapca56 ;; @@ -1093,7 +1095,17 @@ EOF echo "$UNAME_MACHINE"-dec-linux-"$LIBC" exit ;; x86_64:Linux:*:*) - echo "$UNAME_MACHINE"-pc-linux-"$LIBC" + set_cc_for_build + LIBCABI=$LIBC + if [ "$CC_FOR_BUILD" != no_compiler_found ]; then + if (echo '#ifdef __ILP32__'; echo IS_X32; echo '#endif') | \ + (CCOPTS="" $CC_FOR_BUILD -E - 2>/dev/null) | \ + grep IS_X32 >/dev/null + then + LIBCABI="$LIBC"x32 + fi + fi + echo "$UNAME_MACHINE"-pc-linux-"$LIBCABI" exit ;; xtensa*:Linux:*:*) echo "$UNAME_MACHINE"-unknown-linux-"$LIBC" @@ -1627,6 +1639,12 @@ copies of config.guess and config.sub with the latest versions from: https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.guess and https://git.savannah.gnu.org/gitweb/?p=config.git;a=blob_plain;f=config.sub +EOF + +year=`echo $timestamp | sed 's,-.*,,'` +# shellcheck disable=SC2003 +if test "`expr "\`date +%Y\`" - "$year"`" -lt 3 ; then + cat >&2 <<EOF If $0 has already been updated, send the following data and any information you think might be pertinent to config-patches@gnu.org to @@ -1654,6 +1672,7 @@ UNAME_RELEASE = "$UNAME_RELEASE" UNAME_SYSTEM = "$UNAME_SYSTEM" UNAME_VERSION = "$UNAME_VERSION" EOF +fi exit 1 diff --git a/build-aux/config.sub b/build-aux/config.sub index df031b3c853..ce89d5c546c 100755 --- a/build-aux/config.sub +++ b/build-aux/config.sub @@ -2,7 +2,7 @@ # Configuration validation subroutine script. # Copyright 1992-2020 Free Software Foundation, Inc. -timestamp='2019-06-30' +timestamp='2020-06-28' # This file is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by @@ -67,7 +67,7 @@ Report bugs and patches to <config-patches@gnu.org>." version="\ GNU config.sub ($timestamp) -Copyright 1992-2019 Free Software Foundation, Inc. +Copyright 1992-2020 Free Software Foundation, Inc. This is free software; see the source for copying conditions. There is NO warranty; not even for MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE." @@ -124,28 +124,27 @@ case $1 in ;; *-*-*-*) basic_machine=$field1-$field2 - os=$field3-$field4 + basic_os=$field3-$field4 ;; *-*-*) # Ambiguous whether COMPANY is present, or skipped and KERNEL-OS is two # parts maybe_os=$field2-$field3 case $maybe_os in - nto-qnx* | linux-gnu* | linux-android* | linux-dietlibc \ - | linux-newlib* | linux-musl* | linux-uclibc* | uclinux-uclibc* \ + nto-qnx* | linux-* | uclinux-uclibc* \ | uclinux-gnu* | kfreebsd*-gnu* | knetbsd*-gnu* | netbsd*-gnu* \ | netbsd*-eabi* | kopensolaris*-gnu* | cloudabi*-eabi* \ | storm-chaos* | os2-emx* | rtmk-nova*) basic_machine=$field1 - os=$maybe_os + basic_os=$maybe_os ;; android-linux) basic_machine=$field1-unknown - os=linux-android + basic_os=linux-android ;; *) basic_machine=$field1-$field2 - os=$field3 + basic_os=$field3 ;; esac ;; @@ -154,7 +153,7 @@ case $1 in case $field1-$field2 in decstation-3100) basic_machine=mips-dec - os= + basic_os= ;; *-*) # Second component is usually, but not always the OS @@ -162,7 +161,7 @@ case $1 in # Prevent following clause from handling this valid os sun*os*) basic_machine=$field1 - os=$field2 + basic_os=$field2 ;; # Manufacturers dec* | mips* | sequent* | encore* | pc533* | sgi* | sony* \ @@ -175,11 +174,11 @@ case $1 in | microblaze* | sim | cisco \ | oki | wec | wrs | winbond) basic_machine=$field1-$field2 - os= + basic_os= ;; *) basic_machine=$field1 - os=$field2 + basic_os=$field2 ;; esac ;; @@ -191,447 +190,451 @@ case $1 in case $field1 in 386bsd) basic_machine=i386-pc - os=bsd + basic_os=bsd ;; a29khif) basic_machine=a29k-amd - os=udi + basic_os=udi ;; adobe68k) basic_machine=m68010-adobe - os=scout + basic_os=scout ;; alliant) basic_machine=fx80-alliant - os= + basic_os= ;; altos | altos3068) basic_machine=m68k-altos - os= + basic_os= ;; am29k) basic_machine=a29k-none - os=bsd + basic_os=bsd ;; amdahl) basic_machine=580-amdahl - os=sysv + basic_os=sysv ;; amiga) basic_machine=m68k-unknown - os= + basic_os= ;; amigaos | amigados) basic_machine=m68k-unknown - os=amigaos + basic_os=amigaos ;; amigaunix | amix) basic_machine=m68k-unknown - os=sysv4 + basic_os=sysv4 ;; apollo68) basic_machine=m68k-apollo - os=sysv + basic_os=sysv ;; apollo68bsd) basic_machine=m68k-apollo - os=bsd + basic_os=bsd ;; aros) basic_machine=i386-pc - os=aros + basic_os=aros ;; aux) basic_machine=m68k-apple - os=aux + basic_os=aux ;; balance) basic_machine=ns32k-sequent - os=dynix + basic_os=dynix ;; blackfin) basic_machine=bfin-unknown - os=linux + basic_os=linux ;; cegcc) basic_machine=arm-unknown - os=cegcc + basic_os=cegcc ;; convex-c1) basic_machine=c1-convex - os=bsd + basic_os=bsd ;; convex-c2) basic_machine=c2-convex - os=bsd + basic_os=bsd ;; convex-c32) basic_machine=c32-convex - os=bsd + basic_os=bsd ;; convex-c34) basic_machine=c34-convex - os=bsd + basic_os=bsd ;; convex-c38) basic_machine=c38-convex - os=bsd + basic_os=bsd ;; cray) basic_machine=j90-cray - os=unicos + basic_os=unicos ;; crds | unos) basic_machine=m68k-crds - os= + basic_os= ;; da30) basic_machine=m68k-da30 - os= + basic_os= ;; decstation | pmax | pmin | dec3100 | decstatn) basic_machine=mips-dec - os= + basic_os= ;; delta88) basic_machine=m88k-motorola - os=sysv3 + basic_os=sysv3 ;; dicos) basic_machine=i686-pc - os=dicos + basic_os=dicos ;; djgpp) basic_machine=i586-pc - os=msdosdjgpp + basic_os=msdosdjgpp ;; ebmon29k) basic_machine=a29k-amd - os=ebmon + basic_os=ebmon ;; es1800 | OSE68k | ose68k | ose | OSE) basic_machine=m68k-ericsson - os=ose + basic_os=ose ;; gmicro) basic_machine=tron-gmicro - os=sysv + basic_os=sysv ;; go32) basic_machine=i386-pc - os=go32 + basic_os=go32 ;; h8300hms) basic_machine=h8300-hitachi - os=hms + basic_os=hms ;; h8300xray) basic_machine=h8300-hitachi - os=xray + basic_os=xray ;; h8500hms) basic_machine=h8500-hitachi - os=hms + basic_os=hms ;; harris) basic_machine=m88k-harris - os=sysv3 + basic_os=sysv3 ;; hp300 | hp300hpux) basic_machine=m68k-hp - os=hpux + basic_os=hpux ;; hp300bsd) basic_machine=m68k-hp - os=bsd + basic_os=bsd ;; hppaosf) basic_machine=hppa1.1-hp - os=osf + basic_os=osf ;; hppro) basic_machine=hppa1.1-hp - os=proelf + basic_os=proelf ;; i386mach) basic_machine=i386-mach - os=mach + basic_os=mach ;; isi68 | isi) basic_machine=m68k-isi - os=sysv + basic_os=sysv ;; m68knommu) basic_machine=m68k-unknown - os=linux + basic_os=linux ;; magnum | m3230) basic_machine=mips-mips - os=sysv + basic_os=sysv ;; merlin) basic_machine=ns32k-utek - os=sysv + basic_os=sysv ;; mingw64) basic_machine=x86_64-pc - os=mingw64 + basic_os=mingw64 ;; mingw32) basic_machine=i686-pc - os=mingw32 + basic_os=mingw32 ;; mingw32ce) basic_machine=arm-unknown - os=mingw32ce + basic_os=mingw32ce ;; monitor) basic_machine=m68k-rom68k - os=coff + basic_os=coff ;; morphos) basic_machine=powerpc-unknown - os=morphos + basic_os=morphos ;; moxiebox) basic_machine=moxie-unknown - os=moxiebox + basic_os=moxiebox ;; msdos) basic_machine=i386-pc - os=msdos + basic_os=msdos ;; msys) basic_machine=i686-pc - os=msys + basic_os=msys ;; mvs) basic_machine=i370-ibm - os=mvs + basic_os=mvs ;; nacl) basic_machine=le32-unknown - os=nacl + basic_os=nacl ;; ncr3000) basic_machine=i486-ncr - os=sysv4 + basic_os=sysv4 ;; netbsd386) basic_machine=i386-pc - os=netbsd + basic_os=netbsd ;; netwinder) basic_machine=armv4l-rebel - os=linux + basic_os=linux ;; news | news700 | news800 | news900) basic_machine=m68k-sony - os=newsos + basic_os=newsos ;; news1000) basic_machine=m68030-sony - os=newsos + basic_os=newsos ;; necv70) basic_machine=v70-nec - os=sysv + basic_os=sysv ;; nh3000) basic_machine=m68k-harris - os=cxux + basic_os=cxux ;; nh[45]000) basic_machine=m88k-harris - os=cxux + basic_os=cxux ;; nindy960) basic_machine=i960-intel - os=nindy + basic_os=nindy ;; mon960) basic_machine=i960-intel - os=mon960 + basic_os=mon960 ;; nonstopux) basic_machine=mips-compaq - os=nonstopux + basic_os=nonstopux ;; os400) basic_machine=powerpc-ibm - os=os400 + basic_os=os400 ;; OSE68000 | ose68000) basic_machine=m68000-ericsson - os=ose + basic_os=ose ;; os68k) basic_machine=m68k-none - os=os68k + basic_os=os68k ;; paragon) basic_machine=i860-intel - os=osf + basic_os=osf ;; parisc) basic_machine=hppa-unknown - os=linux + basic_os=linux + ;; + psp) + basic_machine=mipsallegrexel-sony + basic_os=psp ;; pw32) basic_machine=i586-unknown - os=pw32 + basic_os=pw32 ;; rdos | rdos64) basic_machine=x86_64-pc - os=rdos + basic_os=rdos ;; rdos32) basic_machine=i386-pc - os=rdos + basic_os=rdos ;; rom68k) basic_machine=m68k-rom68k - os=coff + basic_os=coff ;; sa29200) basic_machine=a29k-amd - os=udi + basic_os=udi ;; sei) basic_machine=mips-sei - os=seiux + basic_os=seiux ;; sequent) basic_machine=i386-sequent - os= + basic_os= ;; sps7) basic_machine=m68k-bull - os=sysv2 + basic_os=sysv2 ;; st2000) basic_machine=m68k-tandem - os= + basic_os= ;; stratus) basic_machine=i860-stratus - os=sysv4 + basic_os=sysv4 ;; sun2) basic_machine=m68000-sun - os= + basic_os= ;; sun2os3) basic_machine=m68000-sun - os=sunos3 + basic_os=sunos3 ;; sun2os4) basic_machine=m68000-sun - os=sunos4 + basic_os=sunos4 ;; sun3) basic_machine=m68k-sun - os= + basic_os= ;; sun3os3) basic_machine=m68k-sun - os=sunos3 + basic_os=sunos3 ;; sun3os4) basic_machine=m68k-sun - os=sunos4 + basic_os=sunos4 ;; sun4) basic_machine=sparc-sun - os= + basic_os= ;; sun4os3) basic_machine=sparc-sun - os=sunos3 + basic_os=sunos3 ;; sun4os4) basic_machine=sparc-sun - os=sunos4 + basic_os=sunos4 ;; sun4sol2) basic_machine=sparc-sun - os=solaris2 + basic_os=solaris2 ;; sun386 | sun386i | roadrunner) basic_machine=i386-sun - os= + basic_os= ;; sv1) basic_machine=sv1-cray - os=unicos + basic_os=unicos ;; symmetry) basic_machine=i386-sequent - os=dynix + basic_os=dynix ;; t3e) basic_machine=alphaev5-cray - os=unicos + basic_os=unicos ;; t90) basic_machine=t90-cray - os=unicos + basic_os=unicos ;; toad1) basic_machine=pdp10-xkl - os=tops20 + basic_os=tops20 ;; tpf) basic_machine=s390x-ibm - os=tpf + basic_os=tpf ;; udi29k) basic_machine=a29k-amd - os=udi + basic_os=udi ;; ultra3) basic_machine=a29k-nyu - os=sym1 + basic_os=sym1 ;; v810 | necv810) basic_machine=v810-nec - os=none + basic_os=none ;; vaxv) basic_machine=vax-dec - os=sysv + basic_os=sysv ;; vms) basic_machine=vax-dec - os=vms + basic_os=vms ;; vsta) basic_machine=i386-pc - os=vsta + basic_os=vsta ;; vxworks960) basic_machine=i960-wrs - os=vxworks + basic_os=vxworks ;; vxworks68) basic_machine=m68k-wrs - os=vxworks + basic_os=vxworks ;; vxworks29k) basic_machine=a29k-wrs - os=vxworks + basic_os=vxworks ;; xbox) basic_machine=i686-pc - os=mingw32 + basic_os=mingw32 ;; ymp) basic_machine=ymp-cray - os=unicos + basic_os=unicos ;; *) basic_machine=$1 - os= + basic_os= ;; esac ;; @@ -683,17 +686,17 @@ case $basic_machine in bluegene*) cpu=powerpc vendor=ibm - os=cnk + basic_os=cnk ;; decsystem10* | dec10*) cpu=pdp10 vendor=dec - os=tops10 + basic_os=tops10 ;; decsystem20* | dec20*) cpu=pdp10 vendor=dec - os=tops20 + basic_os=tops20 ;; delta | 3300 | motorola-3300 | motorola-delta \ | 3300-motorola | delta-motorola) @@ -703,7 +706,7 @@ case $basic_machine in dpx2*) cpu=m68k vendor=bull - os=sysv3 + basic_os=sysv3 ;; encore | umax | mmax) cpu=ns32k @@ -712,7 +715,7 @@ case $basic_machine in elxsi) cpu=elxsi vendor=elxsi - os=${os:-bsd} + basic_os=${basic_os:-bsd} ;; fx2800) cpu=i860 @@ -725,7 +728,7 @@ case $basic_machine in h3050r* | hiux*) cpu=hppa1.1 vendor=hitachi - os=hiuxwe2 + basic_os=hiuxwe2 ;; hp3k9[0-9][0-9] | hp9[0-9][0-9]) cpu=hppa1.0 @@ -768,36 +771,36 @@ case $basic_machine in i*86v32) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc - os=sysv32 + basic_os=sysv32 ;; i*86v4*) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc - os=sysv4 + basic_os=sysv4 ;; i*86v) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc - os=sysv + basic_os=sysv ;; i*86sol2) cpu=`echo "$1" | sed -e 's/86.*/86/'` vendor=pc - os=solaris2 + basic_os=solaris2 ;; j90 | j90-cray) cpu=j90 vendor=cray - os=${os:-unicos} + basic_os=${basic_os:-unicos} ;; iris | iris4d) cpu=mips vendor=sgi - case $os in + case $basic_os in irix*) ;; *) - os=irix4 + basic_os=irix4 ;; esac ;; @@ -808,26 +811,26 @@ case $basic_machine in *mint | mint[0-9]* | *MiNT | *MiNT[0-9]*) cpu=m68k vendor=atari - os=mint + basic_os=mint ;; news-3600 | risc-news) cpu=mips vendor=sony - os=newsos + basic_os=newsos ;; next | m*-next) cpu=m68k vendor=next - case $os in + case $basic_os in openstep*) ;; nextstep*) ;; ns2*) - os=nextstep2 + basic_os=nextstep2 ;; *) - os=nextstep3 + basic_os=nextstep3 ;; esac ;; @@ -838,12 +841,12 @@ case $basic_machine in op50n-* | op60c-*) cpu=hppa1.1 vendor=oki - os=proelf + basic_os=proelf ;; pa-hitachi) cpu=hppa1.1 vendor=hitachi - os=hiuxwe2 + basic_os=hiuxwe2 ;; pbd) cpu=sparc @@ -880,12 +883,12 @@ case $basic_machine in sde) cpu=mipsisa32 vendor=sde - os=${os:-elf} + basic_os=${basic_os:-elf} ;; simso-wrs) cpu=sparclite vendor=wrs - os=vxworks + basic_os=vxworks ;; tower | tower-32) cpu=m68k @@ -902,7 +905,7 @@ case $basic_machine in w89k-*) cpu=hppa1.1 vendor=winbond - os=proelf + basic_os=proelf ;; none) cpu=none @@ -955,11 +958,11 @@ case $cpu-$vendor in # some cases the only manufacturer, in others, it is the most popular. craynv-unknown) vendor=cray - os=${os:-unicosmp} + basic_os=${basic_os:-unicosmp} ;; c90-unknown | c90-cray) vendor=cray - os=${os:-unicos} + basic_os=${Basic_os:-unicos} ;; fx80-unknown) vendor=alliant @@ -1003,7 +1006,7 @@ case $cpu-$vendor in dpx20-unknown | dpx20-bull) cpu=rs6000 vendor=bull - os=${os:-bosx} + basic_os=${basic_os:-bosx} ;; # Here we normalize CPU types irrespective of the vendor @@ -1012,7 +1015,7 @@ case $cpu-$vendor in ;; blackfin-*) cpu=bfin - os=linux + basic_os=linux ;; c54x-*) cpu=tic54x @@ -1025,7 +1028,7 @@ case $cpu-$vendor in ;; e500v[12]-*) cpu=powerpc - os=$os"spe" + basic_os=${basic_os}"spe" ;; mips3*-*) cpu=mips64 @@ -1035,7 +1038,7 @@ case $cpu-$vendor in ;; m68knommu-*) cpu=m68k - os=linux + basic_os=linux ;; m9s12z-* | m68hcs12z-* | hcs12z-* | s12z-*) cpu=s12z @@ -1045,7 +1048,7 @@ case $cpu-$vendor in ;; parisc-*) cpu=hppa - os=linux + basic_os=linux ;; pentium-* | p5-* | k5-* | k6-* | nexgen-* | viac3-*) cpu=i586 @@ -1105,7 +1108,7 @@ case $cpu-$vendor in # Recognize the canonical CPU Types that limit and/or modify the # company names they are paired with. cr16-*) - os=${os:-elf} + basic_os=${basic_os:-elf} ;; crisv32-* | etraxfs*-*) cpu=crisv32 @@ -1116,7 +1119,7 @@ case $cpu-$vendor in vendor=axis ;; crx-*) - os=${os:-elf} + basic_os=${basic_os:-elf} ;; neo-tandem) cpu=neo @@ -1138,16 +1141,12 @@ case $cpu-$vendor in cpu=nsx vendor=tandem ;; - s390-*) - cpu=s390 - vendor=ibm - ;; - s390x-*) - cpu=s390x - vendor=ibm + mipsallegrexel-sony) + cpu=mipsallegrexel + vendor=sony ;; tile*-*) - os=${os:-linux-gnu} + basic_os=${basic_os:-linux-gnu} ;; *) @@ -1229,6 +1228,7 @@ case $cpu-$vendor in | pyramid \ | riscv | riscv32 | riscv64 \ | rl78 | romp | rs6000 | rx \ + | s390 | s390x \ | score \ | sh | shl \ | sh[1234] | sh[24]a | sh[24]ae[lb] | sh[23]e | she[lb] | sh[lb]e \ @@ -1275,8 +1275,43 @@ esac # Decode manufacturer-specific aliases for certain operating systems. -if [ x$os != x ] +if [ x$basic_os != x ] then + +# First recognize some ad-hoc caes, or perhaps split kernel-os, or else just +# set os. +case $basic_os in + gnu/linux*) + kernel=linux + os=`echo $basic_os | sed -e 's|gnu/linux|gnu|'` + ;; + nto-qnx*) + kernel=nto + os=`echo $basic_os | sed -e 's|nto-qnx|qnx|'` + ;; + *-*) + # shellcheck disable=SC2162 + IFS="-" read kernel os <<EOF +$basic_os +EOF + ;; + # Default OS when just kernel was specified + nto*) + kernel=nto + os=`echo $basic_os | sed -e 's|nto|qnx|'` + ;; + linux*) + kernel=linux + os=`echo $basic_os | sed -e 's|linux|gnu|'` + ;; + *) + kernel= + os=$basic_os + ;; +esac + +# Now, normalize the OS (knowing we just have one component, it's not a kernel, +# etc.) case $os in # First match some system type aliases that might get confused # with valid system types. @@ -1296,9 +1331,6 @@ case $os in unixware*) os=sysv4.2uw ;; - gnu/linux*) - os=`echo $os | sed -e 's|gnu/linux|linux-gnu|'` - ;; # es1800 is here to avoid being matched by es* (a different OS) es1800*) os=ose @@ -1322,10 +1354,7 @@ case $os in sco3.2.[4-9]*) os=`echo $os | sed -e 's/sco3.2./sco3.2v/'` ;; - sco3.2v[4-9]* | sco5v6*) - # Don't forget version if it is 3.2v4 or newer. - ;; - scout) + sco*v* | scout) # Don't match below ;; sco*) @@ -1334,41 +1363,6 @@ case $os in psos*) os=psos ;; - # Now accept the basic system types. - # The portable systems comes first. - # Each alternative MUST end in a * to match a version number. - # sysv* is not here because it comes later, after sysvr4. - gnu* | bsd* | mach* | minix* | genix* | ultrix* | irix* \ - | *vms* | esix* | aix* | cnk* | sunos | sunos[34]*\ - | hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \ - | sym* | kopensolaris* | plan9* \ - | amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \ - | aos* | aros* | cloudabi* | sortix* | twizzler* \ - | nindy* | vxsim* | vxworks* | ebmon* | hms* | mvs* \ - | clix* | riscos* | uniplus* | iris* | isc* | rtu* | xenix* \ - | knetbsd* | mirbsd* | netbsd* \ - | bitrig* | openbsd* | solidbsd* | libertybsd* | os108* \ - | ekkobsd* | kfreebsd* | freebsd* | riscix* | lynxos* \ - | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \ - | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \ - | udi* | eabi* | lites* | ieee* | go32* | aux* | hcos* \ - | chorusrdb* | cegcc* | glidix* \ - | cygwin* | msys* | pe* | moss* | proelf* | rtems* \ - | midipix* | mingw32* | mingw64* | linux-gnu* | linux-android* \ - | linux-newlib* | linux-musl* | linux-uclibc* \ - | uxpv* | beos* | mpeix* | udk* | moxiebox* \ - | interix* | uwin* | mks* | rhapsody* | darwin* \ - | openstep* | oskit* | conix* | pw32* | nonstopux* \ - | storm-chaos* | tops10* | tenex* | tops20* | its* \ - | os2* | vos* | palmos* | uclinux* | nucleus* \ - | morphos* | superux* | rtmk* | windiss* \ - | powermax* | dnix* | nx6 | nx7 | sei* | dragonfly* \ - | skyos* | haiku* | rdos* | toppers* | drops* | es* \ - | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \ - | midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \ - | nsk* | powerunix) - # Remember, each alternative MUST END IN *, to match a version number. - ;; qnx*) case $cpu in x86 | i*86) @@ -1381,31 +1375,19 @@ case $os in hiux*) os=hiuxwe2 ;; - nto-qnx*) - ;; - nto*) - os=`echo $os | sed -e 's|nto|nto-qnx|'` - ;; - sim | xray | os68k* | v88r* \ - | windows* | osx | abug | netware* | os9* \ - | macos* | mpw* | magic* | mmixware* | mon960* | lnews*) - ;; - linux-dietlibc) - os=linux-dietlibc - ;; - linux*) - os=`echo $os | sed -e 's|linux|linux-gnu|'` - ;; lynx*178) os=lynxos178 ;; lynx*5) os=lynxos5 ;; + lynxos*) + # don't get caught up in next wildcard + ;; lynx*) os=lynxos ;; - mac*) + mac[0-9]*) os=`echo "$os" | sed -e 's|mac|macos|'` ;; opened*) @@ -1475,18 +1457,12 @@ case $os in sysvr4) os=sysv4 ;; - # This must come after sysvr4. - sysv*) - ;; ose*) os=ose ;; *mint | mint[0-9]* | *MiNT | MiNT[0-9]*) os=mint ;; - zvmoe) - os=zvmoe - ;; dicos*) os=dicos ;; @@ -1503,19 +1479,11 @@ case $os in ;; esac ;; - nacl*) - ;; - ios) - ;; - none) - ;; - *-eabi) - ;; *) - echo Invalid configuration \`"$1"\': system \`"$os"\' not recognized 1>&2 - exit 1 + # No normalization, but not necessarily accepted, that comes below. ;; esac + else # Here we handle the default operating systems that come with various machines. @@ -1528,6 +1496,7 @@ else # will signal an error saying that MANUFACTURER isn't an operating # system, and we'll never get to this point. +kernel= case $cpu-$vendor in score-*) os=elf @@ -1539,7 +1508,8 @@ case $cpu-$vendor in os=riscix1.2 ;; arm*-rebel) - os=linux + kernel=linux + os=gnu ;; arm*-semi) os=aout @@ -1705,84 +1675,169 @@ case $cpu-$vendor in os=none ;; esac + fi +# Now, validate our (potentially fixed-up) OS. +case $os in + # Sometimes we do "kernel-abi", so those need to count as OSes. + musl* | newlib* | uclibc*) + ;; + # Likewise for "kernel-libc" + eabi | eabihf | gnueabi | gnueabihf) + ;; + # Now accept the basic system types. + # The portable systems comes first. + # Each alternative MUST end in a * to match a version number. + gnu* | android* | bsd* | mach* | minix* | genix* | ultrix* | irix* \ + | *vms* | esix* | aix* | cnk* | sunos | sunos[34]* \ + | hpux* | unos* | osf* | luna* | dgux* | auroraux* | solaris* \ + | sym* | plan9* | psp* | sim* | xray* | os68k* | v88r* \ + | hiux* | abug | nacl* | netware* | windows* \ + | os9* | macos* | osx* | ios* \ + | mpw* | magic* | mmixware* | mon960* | lnews* \ + | amigaos* | amigados* | msdos* | newsos* | unicos* | aof* \ + | aos* | aros* | cloudabi* | sortix* | twizzler* \ + | nindy* | vxsim* | vxworks* | ebmon* | hms* | mvs* \ + | clix* | riscos* | uniplus* | iris* | isc* | rtu* | xenix* \ + | mirbsd* | netbsd* | dicos* | openedition* | ose* \ + | bitrig* | openbsd* | solidbsd* | libertybsd* | os108* \ + | ekkobsd* | freebsd* | riscix* | lynxos* | os400* \ + | bosx* | nextstep* | cxux* | aout* | elf* | oabi* \ + | ptx* | coff* | ecoff* | winnt* | domain* | vsta* \ + | udi* | lites* | ieee* | go32* | aux* | hcos* \ + | chorusrdb* | cegcc* | glidix* \ + | cygwin* | msys* | pe* | moss* | proelf* | rtems* \ + | midipix* | mingw32* | mingw64* | mint* \ + | uxpv* | beos* | mpeix* | udk* | moxiebox* \ + | interix* | uwin* | mks* | rhapsody* | darwin* \ + | openstep* | oskit* | conix* | pw32* | nonstopux* \ + | storm-chaos* | tops10* | tenex* | tops20* | its* \ + | os2* | vos* | palmos* | uclinux* | nucleus* | morphos* \ + | scout* | superux* | sysv* | rtmk* | tpf* | windiss* \ + | powermax* | dnix* | nx6 | nx7 | sei* | dragonfly* \ + | skyos* | haiku* | rdos* | toppers* | drops* | es* \ + | onefs* | tirtos* | phoenix* | fuchsia* | redox* | bme* \ + | midnightbsd* | amdhsa* | unleashed* | emscripten* | wasi* \ + | nsk* | powerunix* | genode* | zvmoe* ) + ;; + # This one is extra strict with allowed versions + sco3.2v2 | sco3.2v[4-9]* | sco5v6*) + # Don't forget version if it is 3.2v4 or newer. + ;; + none) + ;; + *) + echo Invalid configuration \`"$1"\': OS \`"$os"\' not recognized 1>&2 + exit 1 + ;; +esac + +# As a final step for OS-related things, validate the OS-kernel combination +# (given a valid OS), if there is a kernel. +case $kernel-$os in + linux-gnu* | linux-dietlibc* | linux-android* | linux-newlib* | linux-musl* | linux-uclibc* ) + ;; + -dietlibc* | -newlib* | -musl* | -uclibc* ) + # These are just libc implementations, not actual OSes, and thus + # require a kernel. + echo "Invalid configuration \`$1': libc \`$os' needs explicit kernel." 1>&2 + exit 1 + ;; + kfreebsd*-gnu* | kopensolaris*-gnu*) + ;; + nto-qnx*) + ;; + *-eabi* | *-gnueabi*) + ;; + -*) + # Blank kernel with real OS is always fine. + ;; + *-*) + echo "Invalid configuration \`$1': Kernel \`$kernel' not known to work with OS \`$os'." 1>&2 + exit 1 + ;; +esac + # Here we handle the case where we know the os, and the CPU type, but not the # manufacturer. We pick the logical manufacturer. case $vendor in unknown) - case $os in - riscix*) + case $cpu-$os in + *-riscix*) vendor=acorn ;; - sunos*) + *-sunos*) vendor=sun ;; - cnk*|-aix*) + *-cnk* | *-aix*) vendor=ibm ;; - beos*) + *-beos*) vendor=be ;; - hpux*) + *-hpux*) vendor=hp ;; - mpeix*) + *-mpeix*) vendor=hp ;; - hiux*) + *-hiux*) vendor=hitachi ;; - unos*) + *-unos*) vendor=crds ;; - dgux*) + *-dgux*) vendor=dg ;; - luna*) + *-luna*) vendor=omron ;; - genix*) + *-genix*) vendor=ns ;; - clix*) + *-clix*) vendor=intergraph ;; - mvs* | opened*) + *-mvs* | *-opened*) + vendor=ibm + ;; + *-os400*) vendor=ibm ;; - os400*) + s390-* | s390x-*) vendor=ibm ;; - ptx*) + *-ptx*) vendor=sequent ;; - tpf*) + *-tpf*) vendor=ibm ;; - vxsim* | vxworks* | windiss*) + *-vxsim* | *-vxworks* | *-windiss*) vendor=wrs ;; - aux*) + *-aux*) vendor=apple ;; - hms*) + *-hms*) vendor=hitachi ;; - mpw* | macos*) + *-mpw* | *-macos*) vendor=apple ;; - *mint | mint[0-9]* | *MiNT | MiNT[0-9]*) + *-*mint | *-mint[0-9]* | *-*MiNT | *-MiNT[0-9]*) vendor=atari ;; - vos*) + *-vos*) vendor=stratus ;; esac ;; esac -echo "$cpu-$vendor-$os" +echo "$cpu-$vendor-${kernel:+$kernel-}$os" exit # Local variables: diff --git a/build-aux/gitlog-to-changelog b/build-aux/gitlog-to-changelog index 511276757f5..be8082e7ffd 100755 --- a/build-aux/gitlog-to-changelog +++ b/build-aux/gitlog-to-changelog @@ -31,11 +31,11 @@ # are valid code in both sh and perl. When executed by sh, they re-execute # the script through the perl program found in $PATH. The '-x' option # is essential as well; without it, perl would re-execute the script -# through /bin/sh. When executed by perl, the next two lines are a no-op. +# through /bin/sh. When executed by perl, the next two lines are a no-op. eval 'exec perl -wSx "$0" "$@"' if 0; -my $VERSION = '2018-03-07 03:47'; # UTC +my $VERSION = '2020-04-04 15:07'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook diff --git a/build-aux/update-copyright b/build-aux/update-copyright index 4f79b56be78..d9b7f683a08 100755 --- a/build-aux/update-copyright +++ b/build-aux/update-copyright @@ -133,11 +133,11 @@ # are valid code in both sh and perl. When executed by sh, they re-execute # the script through the perl program found in $PATH. The '-x' option # is essential as well; without it, perl would re-execute the script -# through /bin/sh. When executed by perl, the next two lines are a no-op. +# through /bin/sh. When executed by perl, the next two lines are a no-op. eval 'exec perl -wSx -0777 -pi "$0" "$@"' if 0; -my $VERSION = '2018-03-07.03:47'; # UTC +my $VERSION = '2020-04-04.15:07'; # UTC # The definition above must lie within the first 8 lines in order # for the Emacs time-stamp write hook (at end) to update it. # If you change this file with Emacs, please let the write hook diff --git a/configure.ac b/configure.ac index 40bc610f9bf..148c50e0b39 100644 --- a/configure.ac +++ b/configure.ac @@ -23,7 +23,7 @@ dnl along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. AC_PREREQ(2.65) dnl Note this is parsed by (at least) make-dist and lisp/cedet/ede/emacs.el. -AC_INIT(GNU Emacs, 27.1, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/) +AC_INIT(GNU Emacs, 28.0.50, bug-gnu-emacs@gnu.org, , https://www.gnu.org/software/emacs/) dnl Set emacs_config_options to the options of 'configure', quoted for the shell, dnl and then quoted again for a C string. Separate options with spaces. @@ -414,7 +414,11 @@ this option's value should be 'yes', 'no', 'lucid', 'athena', 'motif', 'gtk', with_x_toolkit=$val ]) -OPTION_DEFAULT_OFF([wide-int], [prefer wide Emacs integers (typically 62-bit); allows buffer and string size up to 2GB on 32-bit hosts, at the cost of 10% to 30% slowdown of Lisp interpreter and larger memory footprint]) +OPTION_DEFAULT_OFF([wide-int], + [prefer wide Emacs integers (typically 62-bit); + on 32-bit hosts, this allows buffer and string size up to 2GB, + at the cost of 10% to 30% slowdown of Lisp interpreter + and larger memory footprint]) if test "$with_wide_int" = yes; then AC_DEFINE([WIDE_EMACS_INT], 1, [Use long long for EMACS_INT if available.]) fi @@ -430,9 +434,10 @@ OPTION_DEFAULT_ON([png],[don't compile with PNG image support]) OPTION_DEFAULT_ON([rsvg],[don't compile with SVG image support]) OPTION_DEFAULT_ON([lcms2],[don't compile with Little CMS support]) OPTION_DEFAULT_ON([libsystemd],[don't compile with libsystemd support]) -OPTION_DEFAULT_OFF([cairo],[compile with Cairo drawing]) +OPTION_DEFAULT_ON([cairo],[don't compile with Cairo drawing]) OPTION_DEFAULT_ON([xml2],[don't compile with XML parsing support]) OPTION_DEFAULT_OFF([imagemagick],[compile with ImageMagick image support]) +OPTION_DEFAULT_ON([native-image-api], [don't use native image APIs (GDI+ on Windows)]) OPTION_DEFAULT_ON([json], [don't compile with native JSON support]) OPTION_DEFAULT_ON([xft],[don't use XFT for anti aliased fonts]) @@ -882,11 +887,6 @@ for func in $ac_func_list; do test $func = pthread_sigmask || AS_VAR_APPEND([funcs], [" $func"]) done ac_func_list=$funcs -# Use the system putenv even if it lacks GNU features, as we don't need them, -# and the gnulib replacement runs afoul of a FreeBSD 10.1 bug; see Bug#19874. -AC_CHECK_FUNCS_ONCE([putenv]) -AC_DEFUN([gl_FUNC_PUTENV], - [test "$ac_cv_func_putenv" = yes || REPLACE_PUTENV=1]) # Emacs does not use the wchar or wctype-h modules. AC_DEFUN([gt_TYPE_WINT_T], [GNULIB_OVERRIDES_WINT_T=0 @@ -1030,14 +1030,17 @@ AS_IF([test $gl_gcc_warnings = no], ;; esac AS_IF([test $gl_gcc_warnings = yes], - [WERROR_CFLAGS=-Werror]) + [WERROR_CFLAGS=-Werror], + [# Use -fanalyzer and related options only if --enable-gcc-warnings, + # as they slow GCC considerably. + nw="$nw -fanalyzer -Wno-analyzer-double-free -Wno-analyzer-malloc-leak" + nw="$nw -Wno-analyzer-null-dereference -Wno-analyzer-use-after-free"]) - nw="$nw -Wcast-align -Wcast-align=strict" # Emacs is tricky with pointers. + nw="$nw -Wcast-align=strict" # Emacs is tricky with pointers. nw="$nw -Wduplicated-branches" # Too many false alarms nw="$nw -Wformat-overflow=2" # False alarms due to GCC bug 80776 nw="$nw -Wsystem-headers" # Don't let system headers trigger warnings nw="$nw -Woverlength-strings" # Not a problem these days - nw="$nw -Wformat-nonliteral" # we do this a lot nw="$nw -Wvla" # Emacs uses <vla.h>. nw="$nw -Wunused-const-variable=2" # lisp.h declares const objects. nw="$nw -Winline" # OK to ignore 'inline' @@ -1046,7 +1049,6 @@ AS_IF([test $gl_gcc_warnings = no], nw="$nw -Wsync-nand" # irrelevant here, and provokes ObjC warning nw="$nw -Wunsafe-loop-optimizations" # OK to suppress unsafe optimizations nw="$nw -Wbad-function-cast" # These casts are no worse than others. - nw="$nw -Wabi" # Not useful, perceived as noise # Emacs doesn't care about shadowing; see # <https://lists.gnu.org/r/emacs-diffs/2011-11/msg00265.html>. @@ -1066,26 +1068,12 @@ AS_IF([test $gl_gcc_warnings = no], # option problematic. nw="$nw -Wsuggest-attribute=pure" - # This part is merely for shortening the command line, - # since -Wall implies -Wswitch. - nw="$nw -Wswitch" - - # This part is merely for shortening the command line, - # since -Wno-FOO needs to be added below regardless. - nw="$nw -Wmissing-field-initializers" - nw="$nw -Woverride-init" - nw="$nw -Wtype-limits" - nw="$nw -Wunused-parameter" - if test "$emacs_cv_clang" = yes; then - nw="$nw -Wcast-align" nw="$nw -Wdouble-promotion" - nw="$nw -Wmissing-braces" fi - # These cause too much noise in the MinGW build + # This causes too much noise in the MinGW build. if test $opsys = mingw32; then - nw="$nw -Wpointer-sign" nw="$nw -Wsuggest-attribute=format" fi @@ -1251,18 +1239,12 @@ emacs_cv_ln_s_fileonly='cp -p' dnl On MinGW, ensure we will call the MSYS /bin/ln.exe, not some dnl random program in the current directory. if (echo >conf$$.file) 2>/dev/null; then - if ln -s conf$$.file conf$$ 2>/dev/null; then - if test "$opsys" = "mingw32"; then - emacs_cv_ln_s_fileonly='/bin/ln -s' - else - emacs_cv_ln_s_fileonly='ln -s' - fi + if test "$opsys" = "mingw32"; then + emacs_cv_ln_s_fileonly=/bin/ln + elif ln -s conf$$.file conf$$ 2>/dev/null; then + emacs_cv_ln_s_fileonly='ln -s' elif ln conf$$.file conf$$ 2>/dev/null; then - if test "$opsys" = "mingw32"; then - emacs_cv_ln_s_fileonly=/bin/ln - else - emacs_cv_ln_s_fileonly=ln - fi + emacs_cv_ln_s_fileonly=ln fi fi @@ -1508,6 +1490,7 @@ case "$opsys" in UNEXEC_OBJ=unexelf.o ;; esac +AC_SUBST(UNEXEC_OBJ) LD_SWITCH_SYSTEM= test "$with_unexec" = no || case "$opsys" in @@ -1561,8 +1544,6 @@ C_SWITCH_MACHINE= test $with_unexec = yes && case $canonical in alpha*) - AC_CHECK_DECL([__ELF__]) - if test "$ac_cv_have_decl___ELF__" = "yes"; then ## With ELF, make sure that all common symbols get allocated to in the ## data section. Otherwise, the dump of temacs may miss variables in ## the shared library that have been initialized. For example, with @@ -1573,18 +1554,10 @@ case $canonical in else AC_MSG_ERROR([Non-GCC compilers are not supported.]) fi - else - dnl This was the unexalpha.c case. Removed in 24.1, 2010-07-24, - dnl albeit under the mistaken assumption that said file - dnl was no longer used. - AC_MSG_ERROR([Non-ELF systems are not supported since Emacs 24.1.]) - fi ;; esac AC_SUBST(C_SWITCH_MACHINE) -AC_SUBST(UNEXEC_OBJ) - C_SWITCH_SYSTEM= ## Some programs in src produce warnings saying certain subprograms ## are too complex and need a MAXMEM value greater than 2000 for @@ -1929,6 +1902,8 @@ else bitmapdir=${bmd_acc#:} fi +NATIVE_IMAGE_API=no + test "${with_ns}" = maybe && test "${opsys}" != darwin && with_ns=no HAVE_NS=no NS_GNUSTEP_CONFIG=no @@ -2040,6 +2015,11 @@ Either fix this, or re-configure with the option '--without-ns'.])]) AC_MSG_ERROR([Mac OS X 10.6 or newer is required]); fi fi + + if test "${with_native_image_api}" = yes; then + AC_DEFINE(HAVE_NATIVE_IMAGE_API, 1, [Define to use native OS APIs for images.]) + NATIVE_IMAGE_API="yes (ns)" + fi fi AC_SUBST(LIBS_GNUSTEP) @@ -2050,7 +2030,7 @@ NS_OBJ= NS_OBJC_OBJ= if test "${HAVE_NS}" = yes; then if test "$with_toolkit_scroll_bars" = "no"; then - AC_MSG_ERROR([Non-toolkit scroll bars are not implemented for Nextstep.]) + AC_MSG_WARN([Non-toolkit scroll bars are not implemented for Nextstep.]) fi window_system=nextstep @@ -2175,6 +2155,13 @@ if test "${HAVE_W32}" = "yes"; then W32_RES_LINK="-Wl,emacs.res" else W32_OBJ="$W32_OBJ w32.o w32console.o w32heap.o w32inevt.o w32proc.o" + dnl FIXME: This should probably be supported for Cygwin/w32 as + dnl well, but the Cygwin build needs to link against -lgdiplus + if test "${with_native_image_api}" = yes; then + AC_DEFINE(HAVE_NATIVE_IMAGE_API, 1, [Define to use native OS APIs for images.]) + NATIVE_IMAGE_API="yes (w32)" + W32_OBJ="$W32_OBJ w32image.o" + fi W32_LIBS="$W32_LIBS -lwinmm -lusp10 -lgdi32 -lcomdlg32" W32_LIBS="$W32_LIBS -lmpr -lwinspool -lole32 -lcomctl32" W32_RES_LINK="\$(EMACSRES)" @@ -3309,14 +3296,13 @@ if test "${HAVE_X11}" = "yes"; then EMACS_CHECK_MODULES(CAIRO, $CAIRO_MODULE) if test $HAVE_CAIRO = yes; then AC_DEFINE(USE_CAIRO, 1, [Define to 1 if using cairo.]) + CFLAGS="$CFLAGS $CAIRO_CFLAGS" + LIBS="$LIBS $CAIRO_LIBS" + AC_SUBST(CAIRO_CFLAGS) + AC_SUBST(CAIRO_LIBS) else - AC_MSG_ERROR([cairo requested but not found.]) + AC_MSG_WARN([cairo requested but not found.]) fi - - CFLAGS="$CFLAGS $CAIRO_CFLAGS" - LIBS="$LIBS $CAIRO_LIBS" - AC_SUBST(CAIRO_CFLAGS) - AC_SUBST(CAIRO_LIBS) fi fi @@ -3382,8 +3368,6 @@ if test "${HAVE_X11}" = "yes"; then fi # "$HAVE_XFT" != no fi # "x${with_xft}" != "xno" - ## We used to allow building with FreeType and without Xft. - ## However, the ftx font backend driver is not in good shape. if test "$HAVE_XFT" != "yes"; then dnl For the "Does Emacs use" message at the end. HAVE_XFT=no @@ -3589,9 +3573,8 @@ AC_SUBST(LIBXPM) ### Use -ljpeg if available, unless '--with-jpeg=no'. HAVE_JPEG=no LIBJPEG= -if test "${NS_IMPL_COCOA}" = yes; then - : # Cocoa provides its own jpeg support, so do nothing. -elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes"; then +if test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes"; then if test "${with_jpeg}" != "no"; then AC_CACHE_CHECK([for jpeglib 6b or later], [emacs_cv_jpeglib], @@ -3676,8 +3659,13 @@ HAVE_MODULES=no MODULES_OBJ= case $opsys in cygwin|mingw32) MODULES_SUFFIX=".dll" ;; + darwin) MODULES_SUFFIX=".dylib" ;; *) MODULES_SUFFIX=".so" ;; esac +case "${opsys}" in + darwin) MODULES_SECONDARY_SUFFIX='.so' ;; + *) MODULES_SECONDARY_SUFFIX='' ;; +esac if test "${with_modules}" != "no"; then case $opsys in gnu|gnu-linux) @@ -3708,19 +3696,26 @@ if test "${HAVE_MODULES}" = yes; then AC_DEFINE(HAVE_MODULES, 1, [Define to 1 if dynamic modules are enabled]) AC_DEFINE_UNQUOTED(MODULES_SUFFIX, "$MODULES_SUFFIX", [System extension for dynamic libraries]) + if test -n "${MODULES_SECONDARY_SUFFIX}"; then + AC_DEFINE_UNQUOTED(MODULES_SECONDARY_SUFFIX, "$MODULES_SECONDARY_SUFFIX", + [Alternative system extension for dynamic libraries.]) + fi fi AC_SUBST(MODULES_OBJ) AC_SUBST(LIBMODULES) AC_SUBST(HAVE_MODULES) AC_SUBST(MODULES_SUFFIX) +AC_SUBST(MODULES_SECONDARY_SUFFIX) AC_CONFIG_FILES([src/emacs-module.h]) AC_SUBST_FILE([module_env_snippet_25]) AC_SUBST_FILE([module_env_snippet_26]) AC_SUBST_FILE([module_env_snippet_27]) +AC_SUBST_FILE([module_env_snippet_28]) module_env_snippet_25="$srcdir/src/module-env-25.h" module_env_snippet_26="$srcdir/src/module-env-26.h" module_env_snippet_27="$srcdir/src/module-env-27.h" +module_env_snippet_28="$srcdir/src/module-env-28.h" emacs_major_version="${PACKAGE_VERSION%%.*}" AC_SUBST(emacs_major_version) @@ -3728,13 +3723,12 @@ AC_SUBST(emacs_major_version) HAVE_PNG=no LIBPNG= PNG_CFLAGS= -if test "${NS_IMPL_COCOA}" = yes; then - : # Cocoa provides its own png support, so do nothing. -elif test "${with_png}" != no; then +if test "${with_png}" != no; then # mingw32 loads the library dynamically. if test "$opsys" = mingw32; then AC_CHECK_HEADER([png.h], [HAVE_PNG=yes]) - elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes"; then + elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes"; then EMACS_CHECK_MODULES([PNG], [libpng >= 1.0.0]) if test $HAVE_PNG = yes; then LIBPNG=$PNG_LIBS @@ -3808,7 +3802,8 @@ if test "${opsys}" = "mingw32"; then if test "${HAVE_TIFF}" = "yes"; then AC_DEFINE(HAVE_TIFF, 1, [Define to 1 if you have the tiff library (-ltiff).]) fi -elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes"; then +elif test "${HAVE_X11}" = "yes" || test "${HAVE_W32}" = "yes" \ + || test "${HAVE_NS}" = "yes"; then if test "${with_tiff}" != "no"; then AC_CHECK_HEADER(tiffio.h, [tifflibs="-lz -lm" @@ -3837,7 +3832,7 @@ if test "${opsys}" = "mingw32"; then AC_DEFINE(HAVE_GIF, 1, [Define to 1 if you have a gif (or ungif) library.]) fi elif test "${HAVE_X11}" = "yes" && test "${with_gif}" != "no" \ - || test "${HAVE_W32}" = "yes"; then + || test "${HAVE_W32}" = "yes" || test "${HAVE_NS}" = "yes"; then AC_CHECK_HEADER(gif_lib.h, # EGifPutExtensionLast only exists from version libungif-4.1.0b1. # Earlier versions can crash Emacs, but version 5.0 removes EGifPutExtensionLast. @@ -4180,7 +4175,8 @@ pthread_sigmask strsignal setitimer timer_getoverrun \ sendto recvfrom getsockname getifaddrs freeifaddrs \ gai_strerror sync \ getpwent endpwent getgrent endgrent \ -cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np) +cfmakeraw cfsetspeed __executable_start log2 pthread_setname_np \ +pthread_set_name_np) LIBS=$OLD_LIBS if test "$ac_cv_func_pthread_setname_np" = "yes"; then @@ -4219,6 +4215,12 @@ dnl No need to check for posix_memalign if aligned_alloc works. AC_CHECK_FUNCS([aligned_alloc posix_memalign], [break]) AC_CHECK_DECLS([aligned_alloc], [], [], [[#include <stdlib.h>]]) +case $with_unexec,$canonical in + yes,alpha*) + AC_CHECK_DECL([__ELF__], [], + [AC_MSG_ERROR([Non-ELF systems are not supported on this platform.])]);; +esac + # Dump loading AC_CHECK_FUNCS([posix_madvise]) @@ -4505,32 +4507,6 @@ AC_SUBST(KRB5LIB) AC_SUBST(DESLIB) AC_SUBST(KRB4LIB) -AC_ARG_WITH([libgmp], - [AS_HELP_STRING([--without-libgmp], - [don't use the GNU Multiple Precision (GMP) library; - this is the default on systems lacking libgmp.])]) -GMP_LIB= -GMP_OBJ=mini-gmp-emacs.o -HAVE_GMP=no -case $with_libgmp in - no) ;; - yes) HAVE_GMP=yes GMP_LIB=-lgmp;; - *) AC_CHECK_HEADERS([gmp.h], - [OLIBS=$LIBS - AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp]) - LIBS=$OLIBS - case $ac_cv_search___gmpz_roinit_n in - 'none needed') HAVE_GMP=yes;; - -*) HAVE_GMP=yes GMP_LIB=$ac_cv_search___gmpz_roinit_n;; - esac]);; -esac -if test "$HAVE_GMP" = yes; then - GMP_OBJ= - AC_DEFINE([HAVE_GMP], 1, [Define to 1 if you have recent-enough GMP.]) -fi -AC_SUBST([GMP_LIB]) -AC_SUBST([GMP_OBJ]) - AC_CHECK_HEADERS(valgrind/valgrind.h) AC_CHECK_MEMBERS([struct unipair.unicode], [], [], [[#include <linux/kd.h>]]) @@ -4870,11 +4846,11 @@ case $opsys in AC_DEFINE(PTY_TTY_NAME_SPRINTF, []) ;; - gnu | openbsd | qnxnto ) + gnu | qnxnto ) AC_DEFINE(FIRST_PTY_LETTER, ['p']) ;; - gnu-linux | gnu-kfreebsd | dragonfly | freebsd | netbsd | darwin | nacl ) + gnu-linux | gnu-kfreebsd | dragonfly | freebsd | openbsd | netbsd | darwin | nacl ) dnl if HAVE_GRANTPT if test "x$ac_cv_func_grantpt" = xyes; then AC_DEFINE(UNIX98_PTYS, 1, [Define if the system has Unix98 PTYs.]) @@ -5287,9 +5263,9 @@ if test "${HAVE_X_WINDOWS}" = "yes" ; then if test "$HAVE_CAIRO" = "yes"; then FONT_OBJ="$FONT_OBJ ftfont.o ftcrfont.o" elif test "$HAVE_XFT" = "yes"; then - FONT_OBJ="$FONT_OBJ ftfont.o xftfont.o ftxfont.o" + FONT_OBJ="$FONT_OBJ ftfont.o xftfont.o" elif test "$HAVE_FREETYPE" = "yes"; then - FONT_OBJ="$FONT_OBJ ftfont.o ftxfont.o" + FONT_OBJ="$FONT_OBJ ftfont.o" fi fi if test "${HAVE_HARFBUZZ}" = "yes" ; then @@ -5698,6 +5674,11 @@ done AC_DEFINE_UNQUOTED(EMACS_CONFIG_FEATURES, "${emacs_config_features}", [Summary of some of the main features enabled by configure.]) +if test -z "$GMP_H"; then + HAVE_GMP=yes +else + HAVE_GMP=no +fi AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D} Does Emacs use -lXpm? ${HAVE_XPM} Does Emacs use -ljpeg? ${HAVE_JPEG} @@ -5708,6 +5689,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use cairo? ${HAVE_CAIRO} Does Emacs use -llcms2? ${HAVE_LCMS2} Does Emacs use imagemagick? ${HAVE_IMAGEMAGICK} + Does Emacs use native APIs for images? ${NATIVE_IMAGE_API} Does Emacs support sound? ${HAVE_SOUND} Does Emacs use -lgpm? ${HAVE_GPM} Does Emacs use -ldbus? ${HAVE_DBUS} @@ -5725,7 +5707,7 @@ AS_ECHO([" Does Emacs use -lXaw3d? ${HAVE_XAW3D Does Emacs use -lxft? ${HAVE_XFT} Does Emacs use -lsystemd? ${HAVE_LIBSYSTEMD} Does Emacs use -ljansson? ${HAVE_JSON} - Does Emacs use -lgmp? ${HAVE_GMP} + Does Emacs use the GMP library? ${HAVE_GMP} Does Emacs directly use zlib? ${HAVE_ZLIB} Does Emacs have dynamic modules support? ${HAVE_MODULES} Does Emacs use toolkit scroll bars? ${USE_TOOLKIT_SCROLL_BARS} @@ -5905,6 +5887,21 @@ you can continue to support by using '$0 --with-pop'.]) esac fi +if test "${HAVE_XFT}" = yes; then + AC_MSG_WARN([This configuration uses libXft, which has a number of + font rendering issues, and is being considered for removal in the + next release of Emacs. Please consider using Cairo graphics + + HarfBuzz text shaping instead (they are auto-detected if the + relevant development headers are installed).]) +fi + +if test "${HAVE_CAIRO}" = "yes" && test "${HAVE_HARFBUZZ}" = no; then + AC_MSG_WARN([This configuration uses the Cairo graphics library, + but not the HarfBuzz font shaping library. We recommend the use + of HarfBuzz when using Cairo, please install HarfBuzz development + packages.]) +fi + # Let plain 'make' work. test "$MAKE" = make || test -f makefile || cat >makefile <<EOF .POSIX: diff --git a/doc/emacs/building.texi b/doc/emacs/building.texi index fa60ce26621..7074bd45d71 100644 --- a/doc/emacs/building.texi +++ b/doc/emacs/building.texi @@ -975,9 +975,27 @@ displays the following frame layout: @end group @end smallexample +@findex gdb-save-window-configuration +@findex gdb-load-window-configuration +@vindex gdb-default-window-configuration-file +@vindex gdb-window-configuration-directory + You can customize the window layout based on the one above and save +that layout to a file using @code{gdb-save-window-configuration}. +Then you can later load this layout back using +@code{gdb-load-window-configuration}. (Internally, Emacs uses the +term window configuration instead of window layout.) You can set your +custom layout as the default one used by @code{gdb-many-windows} by +customizing @code{gdb-default-window-configuration-file}. If it is +not an absolute file name, GDB looks under +@code{gdb-window-configuration-directory} for the file. +@code{gdb-window-configuration-directory} defaults to +@code{user-emacs-directory} (@pxref{Find Init}). + + @findex gdb-restore-windows @findex gdb-many-windows - If you ever change the window layout, you can restore the many-windows +@vindex gdb-restore-window-configuration-after-quit + If you ever change the window layout, you can restore the default layout by typing @kbd{M-x gdb-restore-windows}. To toggle between the many windows layout and a simple layout with just the GUD interaction buffer and a source file, type @kbd{M-x gdb-many-windows}. @@ -988,7 +1006,13 @@ interaction buffer and a source file, type @kbd{M-x gdb-many-windows}. of windows on your original frame will not be affected. A separate frame for GDB sessions can come in especially handy if you work on a text-mode terminal, where the screen estate for windows could be at a -premium. +premium. If you choose to start GDB in the same frame, consider +setting @code{gdb-restore-window-configuration-after-quit} to a +non-@code{nil} value. Your original layout will then be restored +after GDB quits. Use @code{t} to always restore; use +@code{if-gdb-many-windows} to restore only when +@code{gdb-many-windows} is non-@code{nil}; use @code{if-gdb-show-main} +to restore only when @code{gdb-show-main} is non-@code{nil}. You may also specify additional GDB-related buffers to display, either in the same frame or a different one. Select the buffers you @@ -998,6 +1022,14 @@ is the relevant buffer type, such as @samp{breakpoints}. You can do the same with the menu bar, with the @samp{GDB-Windows} and @samp{GDB-Frames} sub-menus of the @samp{GUD} menu. +@vindex gdb-max-source-window-count +@vindex gdb-display-source-buffer-action +By default, GDB uses at most one window to display the source file. +You can make it use more windows by customizing +@code{gdb-max-source-window-count}. You can also customize +@code{gdb-display-source-buffer-action} to control how GDB displays +source files. + When you finish debugging, kill the GUD interaction buffer with @kbd{C-x k}, which will also kill all the buffers associated with the session. However you need not do this if, after editing and @@ -1536,13 +1568,6 @@ Automatic loading also occurs when completing names for prefix being completed. To disable this feature, change the variable @code{help-enable-completion-autoload} to @code{nil}. -@vindex load-dangerous-libraries -@cindex Lisp files byte-compiled by XEmacs - By default, Emacs refuses to load compiled Lisp files which were -compiled with XEmacs, a modified version of Emacs---they can cause -Emacs to crash. Set the variable @code{load-dangerous-libraries} to -@code{t} if you want to try loading them. - Once you put your library in a directory where Emacs can find and load it, you may wish to make it available at startup. This is useful when the library defines features that should be available diff --git a/doc/emacs/cmdargs.texi b/doc/emacs/cmdargs.texi index 850a802753d..3dd1fe9a308 100644 --- a/doc/emacs/cmdargs.texi +++ b/doc/emacs/cmdargs.texi @@ -495,7 +495,14 @@ variables to be set, but it uses their values if they are set. @item CDPATH @vindex CDPATH@r{, environment variable} Used by the @code{cd} command to search for the directory you specify, -when you specify a relative directory, +when you specify a relative directory. +@item COLORTERM +@vindex COLORTERM@r{, environment variable} +If this variable is set to the value @samp{truecolor}, it tells Emacs +to use 24-bit true color on text-mode displays even if the terminfo +database is not installed. Emacs will use built-in commands to +request true color by RGB values instead of the missing terminfo +information. @item DBUS_SESSION_BUS_ADDRESS @vindex DBUS_SESSION_BUS_ADDRESS@r{, environment variable} Used by D-Bus when Emacs is compiled with it. Usually, there is no @@ -565,12 +572,6 @@ is found there. @item HOSTNAME @vindex HOSTNAME@r{, environment variable} The name of the machine that Emacs is running on. -@c complete.el is obsolete since 24.1. -@ignore -@item INCPATH -A colon-separated list of directories. Used by the @code{complete} package -to search for files. -@end ignore @item INFOPATH @vindex INFOPATH@r{, environment variable} A colon-separated list of directories in which to search for Info files. diff --git a/doc/emacs/custom.texi b/doc/emacs/custom.texi index 00c8ee4f98b..acd7fb13ae1 100644 --- a/doc/emacs/custom.texi +++ b/doc/emacs/custom.texi @@ -1630,6 +1630,10 @@ characters are actually defined by this map. @item @vindex mode-specific-map @code{mode-specific-map} is for characters that follow @kbd{C-c}. +@item +@vindex project-prefix-map +@code{project-prefix-map} is for characters that follow @kbd{C-x p}, +used for project-related commands (@pxref{Projects}). @end itemize @node Local Keymaps diff --git a/doc/emacs/display.texi b/doc/emacs/display.texi index a4040d986e1..e96e43b377d 100644 --- a/doc/emacs/display.texi +++ b/doc/emacs/display.texi @@ -1667,6 +1667,8 @@ Customization}). (The other attributes of this face have no effect; the text shown under the cursor is drawn using the frame's background color.) To change its shape, customize the buffer-local variable @code{cursor-type}; possible values are @code{box} (the default), +@code{(box . @var{size})} (box cursor becoming a hollow box under +masked images larger than @var{size} pixels in either dimension), @code{hollow} (a hollow box), @code{bar} (a vertical bar), @code{(bar . @var{n})} (a vertical bar @var{n} pixels wide), @code{hbar} (a horizontal bar), @code{(hbar . @var{n})} (a horizontal bar @var{n} diff --git a/doc/emacs/emacs.texi b/doc/emacs/emacs.texi index 6b82aeb8234..5b6b7b7e93e 100644 --- a/doc/emacs/emacs.texi +++ b/doc/emacs/emacs.texi @@ -857,6 +857,12 @@ Customizing VC * CVS Options:: Options for CVS. @end ifnottex +Projects + +* Project File Commands:: Commands for handling project files. +* Project Buffer Commands:: Commands for handling project buffers. +* Switching Projects:: Switching between projects. + Change Logs * Change Log Commands:: Commands for editing change log files. diff --git a/doc/emacs/fixit.texi b/doc/emacs/fixit.texi index dc643e19a4b..5046146dda6 100644 --- a/doc/emacs/fixit.texi +++ b/doc/emacs/fixit.texi @@ -66,6 +66,7 @@ changes have already been undone, the undo command signals an error. @cindex redo @findex undo-only +@findex undo-redo Any command other than an undo command breaks the sequence of undo commands. Starting from that moment, the entire sequence of undo commands that you have just performed are themselves placed into the @@ -76,7 +77,9 @@ undo commands. Alternatively, if you want to resume undoing, without redoing previous undo commands, use @kbd{M-x undo-only}. This is like -@code{undo}, but will not redo changes you have just undone. +@code{undo}, but will not redo changes you have just undone. To +complement it, @kbd{M-x undo-redo} will undo previous undo commands +(and will not record itself as an undoable command). If you notice that a buffer has been modified accidentally, the easiest way to recover is to type @kbd{C-/} repeatedly until the stars diff --git a/doc/emacs/frames.texi b/doc/emacs/frames.texi index e0eabe38d06..b99d8ab1453 100644 --- a/doc/emacs/frames.texi +++ b/doc/emacs/frames.texi @@ -439,29 +439,40 @@ buffer to select: @kindex C-x 5 2 @findex make-frame-command Create a new frame (@code{make-frame-command}). + @item C-x 5 b @var{bufname} @key{RET} Select buffer @var{bufname} in another frame. This runs @code{switch-to-buffer-other-frame}. + @item C-x 5 f @var{filename} @key{RET} Visit file @var{filename} and select its buffer in another frame. This runs @code{find-file-other-frame}. @xref{Visiting}. + @item C-x 5 d @var{directory} @key{RET} Select a Dired buffer for directory @var{directory} in another frame. This runs @code{dired-other-frame}. @xref{Dired}. + @item C-x 5 m Start composing a mail message in another frame. This runs @code{compose-mail-other-frame}. It is the other-frame variant of @kbd{C-x m}. @xref{Sending Mail}. + @item C-x 5 . Find the definition of an identifier in another frame. This runs @code{xref-find-definitions-other-frame}, the multiple-frame variant of @kbd{M-.}. @xref{Xref}. + @item C-x 5 r @var{filename} @key{RET} @kindex C-x 5 r @findex find-file-read-only-other-frame Visit file @var{filename} read-only, and select its buffer in another frame. This runs @code{find-file-read-only-other-frame}. @xref{Visiting}. + +@item C-x 5 5 +A more general prefix command affects the buffer displayed by the next +command invoked immediately after this prefix command. It requests +the buffer of the next command to be displayed in another frame. @end table You can control the appearance and behavior of the newly-created @@ -1316,6 +1327,11 @@ runs @code{find-file-other-tab}. @xref{Visiting}. @item C-x t d @var{directory} @key{RET} Select a Dired buffer for directory @var{directory} in another tab. This runs @code{dired-other-tab}. @xref{Dired}. + +@item C-x t t +A more general prefix command affects the buffer displayed by the next +command invoked immediately after this prefix command. It requests +the buffer of the next command to be displayed in another tab. @end table @vindex tab-bar-new-tab-choice diff --git a/doc/emacs/help.texi b/doc/emacs/help.texi index 06ddc11158b..167c32c4d21 100644 --- a/doc/emacs/help.texi +++ b/doc/emacs/help.texi @@ -607,6 +607,11 @@ is @key{ESC}, because @kbd{@key{ESC} C-h} is actually @kbd{C-M-h}, which marks a defun. However, @w{@kbd{@key{ESC} @key{F1}}} and @w{@kbd{@key{ESC} ?}} work fine.) +@findex describe-keymap +Finally, @kbd{M-x describe-keymap} prompts for the name of a keymap, +with completion, and displays a listing of all key bindings in that +keymap. + @node Help Files @section Help Files diff --git a/doc/emacs/m-x.texi b/doc/emacs/m-x.texi index fc2d2d8c84d..b18c334acf4 100644 --- a/doc/emacs/m-x.texi +++ b/doc/emacs/m-x.texi @@ -72,6 +72,10 @@ number, in which case Emacs will show the binding for that many seconds before removing it from display. The default behavior is to display the binding for 2 seconds. +Additionally, when @code{suggest-key-bindings} is non-@code{nil}, the +completion list of @kbd{M-x} shows equivalent key bindings for all +commands that have them. + @vindex extended-command-suggest-shorter Commands that don't have key bindings, can still be invoked after typing less than their full name at the @samp{M-x} prompt. Emacs diff --git a/doc/emacs/maintaining.texi b/doc/emacs/maintaining.texi index ebcdddfcae3..43ec2d4e9f2 100644 --- a/doc/emacs/maintaining.texi +++ b/doc/emacs/maintaining.texi @@ -1656,8 +1656,47 @@ support additional types of projects. the project back-end. For example, the VC back-end doesn't consider ``ignored'' files (@pxref{VC Ignore}) to be part of the project. +@menu +* Project File Commands:: Commands for handling project files. +* Project Buffer Commands:: Commands for handling project buffers. +* Switching Projects:: Switching between projects. +@end menu + +@node Project File Commands +@subsection Project Commands That Operate on Files + +@table @kbd +@item C-x p f +Visit a file that belongs to the current project +(@code{project-find-file}). +@item C-x p g +Find matches for a regexp in all files that belong to the current +project (@code{project-find-regexp}). +@item M-x project-search +Interactively search for regexp matches in all files that belong to +the current project. +@item C-x p r +Perform query-replace for a regexp in all files that belong to the +current project (@code{project-query-replace-regexp}). +@item C-x p d +Run Dired in the current project's root directory +(@code{project-dired}). +@item C-x p v +Run @code{vc-dir} in the current project's root directory +(@code{project-vc-dir}). +@item C-x p s +Start an inferior shell in the current project's root directory +(@code{project-shell}). +@item C-x p e +Start Eshell in the current project's root directory +(@code{project-eshell}). +@item C-x p c +Run compilation in the current project's root directory +(@code{project-compile}). +@end table + Emacs provides commands for handling project files conveniently. -This section describes these commands. +This subsection describes these commands. @cindex current project All of the commands described here share the notion of the @@ -1668,25 +1707,26 @@ doesn't seem to belong to a recognizable project, these commands prompt you for the project directory. @findex project-find-file - The command @code{project-find-file} is a convenient way of visiting -files (@pxref{Visiting}) that belong to the current project. Unlike -@kbd{C-x C-f}, this command doesn't require to type the full file name -of the file to visit, you can type only the file's base name (i.e., -omit the leading directories). In addition, the completion candidates -considered by the command include only the files belonging to the -current project, and nothing else. If there's a file name at point, -this command offers that file as the default to visit. + The command @kbd{C-x p f} (@code{project-find-file}) is a convenient +way of visiting files (@pxref{Visiting}) that belong to the current +project. Unlike @kbd{C-x C-f}, this command doesn't require to type +the full file name of the file to visit, you can type only the file's +base name (i.e., omit the leading directories). In addition, the +completion candidates considered by the command include only the files +belonging to the current project, and nothing else. If there's a file +name at point, this command offers that file as the default to visit. @findex project-find-regexp - The command @code{project-find-regexp} is similar to @code{rgrep} -(@pxref{Grep Searching}), but it searches only the files that belong -to the current project. The command prompts for the regular -expression to search, and pops up an Xref mode buffer with the search -results, where you can select a match using the Xref mode commands -(@pxref{Xref Commands}). When invoked with a prefix argument, this -command additionally prompts for the base directory from which to -start the search; this allows, for example, to limit the search only -to project files under a certain subdirectory of the project root. + The command @kbd{C-x p g} (@code{project-find-regexp}) is similar to +@code{rgrep} (@pxref{Grep Searching}), but it searches only the files +that belong to the current project. The command prompts for the +regular expression to search, and pops up an Xref mode buffer with the +search results, where you can select a match using the Xref mode +commands (@pxref{Xref Commands}). When invoked with a prefix +argument, this command additionally prompts for the base directory +from which to start the search; this allows, for example, to limit the +search only to project files under a certain subdirectory of the +project root. @findex project-search @kbd{M-x project-search} is an interactive variant of @@ -1698,13 +1738,94 @@ matched file. To find the rest of the matches, type @w{@kbd{M-x fileloop-continue @key{RET}}}. @findex project-query-replace-regexp - @kbd{M-x project-query-replace-regexp} is similar to + @kbd{C-x p r} (@code{project-query-replace-regexp}) is similar to @code{project-search}, but it prompts you for whether to replace each match it finds, like @code{query-replace} does (@pxref{Query Replace}), and continues to the next match after you respond. If your response causes Emacs to exit the query-replace loop, you can later continue with @w{@kbd{M-x fileloop-continue @key{RET}}}. +@findex project-dired + The command @kbd{C-x p d} (@code{project-dired}) opens a Dired +buffer (@pxref{Dired}) listing the files in the current project's root +directory. + +@findex project-vc-dir + The command @kbd{C-x p v} (@code{project-vc-dir}) opens a VC +Directory buffer (@pxref{VC Directory Mode}) listing the version +control statuses of the files in a directory tree under the current +project's root directory. + +@findex project-shell + The command @kbd{C-x p s} (@code{project-shell}) starts a shell +session (@pxref{Shell}) in a new buffer with the current project's +root as the working directory. + +@findex project-eshell + The command @kbd{C-x p e} (@code{project-eshell}) starts an Eshell +session in a new buffer with the current project's root as the working +directory. @xref{Top,Eshell,Eshell, eshell, Eshell: The Emacs Shell}. + +@findex project-compile + The command @kbd{C-x p c} (@code{project-compile}) runs compilation +(@pxref{Compilation}) in the current project's root directory. + +@node Project Buffer Commands +@subsection Project Commands That Operate on Buffers + +@table @kbd +@item C-x p b +Switch to another buffer belonging to the current project +(@code{project-switch-to-buffer}). +@item C-x p k +Kill all live buffers that belong to the current project +(@code{project-kill-buffers}). +@end table + +@findex project-switch-to-buffer + Working on a project could potentially involve having many buffers +visiting files that belong to the project, and also buffers that +belong to the project, but don't visit any files (like the +@file{*compilation*} buffer created by @code{project-compile}). The +command @kbd{C-x p b} (@code{project-switch-to-buffer}) helps you +switch between buffers that belong to the current project by prompting +for a buffer to switch and considering only the current project's +buffers as candidates for completion. + +@findex project-kill-buffers +@vindex project-kill-buffers-ignores + When you finish working on the project, you may wish to kill all the +buffers that belong to the project, to keep your Emacs session +smaller. The command @kbd{C-x p k} (@code{project-kill-buffers}) +accomplishes that: it kills all the buffers that belong to the current +project, except if @code{project-kill-buffers-ignores} tells +otherwise. + +@node Switching Projects +@subsection Switching Projects + +@table @kbd +@item C-x p p +Run an Emacs command for another project (@code{project-switch-project}). +@end table + +@findex project-switch-project +@vindex project-switch-commands + Commands that operate on project files (@pxref{Project File +Commands}) will conveniently prompt you for a project directory when +no project is current. When you are inside some project, but you want +to operate on a different project, use the @kbd{C-x p p} command +(@code{project-switch-project}). This command prompts you to choose a +directory among known project roots, and then displays the menu of +available commands to operate on the project you choose. The variable +@code{project-switch-commands} controls which commands are available +in the menu, and which key invokes each command. + +@vindex project-list-file + The variable @code{project-list-file} names the file in which Emacs +records the list of known projects. It defaults to the file +@file{projects} in @code{user-emacs-directory} (@pxref{Find Init}). + @node Change Log @section Change Logs diff --git a/doc/emacs/misc.texi b/doc/emacs/misc.texi index 2f02c702512..e7547ebff7c 100644 --- a/doc/emacs/misc.texi +++ b/doc/emacs/misc.texi @@ -2920,9 +2920,17 @@ you might like to bind to keys, such as @code{browse-url-at-point} and You can customize Browse-URL's behavior via various options in the @code{browse-url} Customize group. In particular, the option @code{browse-url-mailto-function} lets you define how to follow -@samp{mailto:} URLs, while @code{browse-url-browser-function} lets you -define how to follow other types of URLs. For more information, view -the package commentary by typing @kbd{C-h P browse-url @key{RET}}. +@samp{mailto:} URLs, while @code{browse-url-browser-function} +specifies your default browser. + +@vindex browse-url-handlers + You can define that certain URLs are browsed with other functions by +customizing @code{browse-url-handlers}, an alist of regular +expressions or predicates paired with functions to browse matching +URLs. + +For more information, view the package commentary by typing @kbd{C-h P +browse-url @key{RET}}. @node Goto Address mode @subsection Activating URLs diff --git a/doc/emacs/msdos.texi b/doc/emacs/msdos.texi index 3275fded565..48492ab2f22 100644 --- a/doc/emacs/msdos.texi +++ b/doc/emacs/msdos.texi @@ -712,6 +712,21 @@ is @code{t}, which means these keys produce @code{AltGr}; setting it to @code{nil} causes @key{AltGr} or the equivalent key combination to be interpreted as the combination of @key{Ctrl} and @key{Meta} modifiers. + +@cindex IME, MS-Windows +@findex w32-set-ime-open-status + Some versions of MS-Windows, typically East Asian localized Windows, +enable the Input Method Manager (@acronym{IMM}) that allows +applications to communicate with the Input Method Editor +(@acronym{IME}), the native Windows input method service. Emacs uses +the @acronym{IME} when available to allow users to input East Asian +non-@acronym{ASCII} characters, similarly to Emacs's built-in input +methods (@pxref{Input Methods}). However, in some situations the +@acronym{IME} can get in the way if it interprets simple +@acronym{ASCII} keys you input as part of a key sequence that +designates a non-@acronym{ASCII} character. The @acronym{IME} can be +temporarily turned off and then on again by using the +@code{w32-set-ime-open-status} function. @end ifnottex @node Windows Mouse diff --git a/doc/emacs/mule.texi b/doc/emacs/mule.texi index 0f07d286cda..6eff0ca0d22 100644 --- a/doc/emacs/mule.texi +++ b/doc/emacs/mule.texi @@ -202,7 +202,7 @@ terminal, the code(s) sent to the terminal. @item If the character was composed on display with any following characters to form one or more grapheme clusters, the composition information: -the font glyphs if the frame is on a graphical display, else the +the font glyphs if the frame is on a graphical display, and the characters that were composed. @item diff --git a/doc/emacs/package.texi b/doc/emacs/package.texi index 517d2b75aa2..453d9eb4010 100644 --- a/doc/emacs/package.texi +++ b/doc/emacs/package.texi @@ -165,27 +165,6 @@ Refresh the package list (@code{revert-buffer}). This fetches the list of available packages from the package archive again, and redisplays the package list. -@item / k -@kindex / k @r{(Package Menu)} -@findex package-menu-filter-by-keyword -Filter the package list by keyword -(@code{package-menu-filter-by-keyword}). This prompts for a keyword -(e.g., @samp{games}), then shows only the packages that relate to that -keyword. - -@item / n -@kindex / n @r{(Package Menu)} -@findex package-menu-filter-by-name -Filter the package list by name (@code{package-menu-filter-by-name}). -This prompts for a string, then shows only the packages whose names -match a regexp with that value. - -@item / / -@kindex / / @r{(Package Menu)} -@findex package-menu-clear-filter -Clear filter currently applied to the package list -(@code{package-menu-clear-filter}). - @item H @kindex H @r{(Package Menu)} @findex package-menu-hide-package @@ -200,6 +179,54 @@ pressing @key{RET} to the prompt will hide the current package. @findex package-menu-toggle-hiding Toggle visibility of old versions of packages and also of versions from lower-priority archives (@code{package-menu-toggle-hiding}). + +@item / a +@kindex / a @r{(Package Menu)} +@findex package-menu-filter-by-archive +Filter package list by archive (@code{package-menu-filter-by-archive}). +This prompts for a package archive (e.g., @samp{gnu}), then shows only +packages from that archive. + +@item / k +@kindex / k @r{(Package Menu)} +@findex package-menu-filter-by-keyword +Filter package list by keyword (@code{package-menu-filter-by-keyword}). +This prompts for a keyword (e.g., @samp{games}), then shows only +packages with that keyword. + +@item / n +@kindex / n @r{(Package Menu)} +@findex package-menu-filter-by-name +Filter package list by name (@code{package-menu-filter-by-name}). +This prompts for a regular expression, then shows only packages +with names matching that regexp. + +@item / s +@kindex / s @r{(Package Menu)} +@findex package-menu-filter-by-status +Filter package list by status (@code{package-menu-filter-by-status}). +This prompts for one or more statuses (e.g., @samp{available}), then +shows only packages with matching status. + +@item / v +@kindex / v @r{(Package Menu)} +@findex package-menu-filter-by-version +Filter package list by version (@code{package-menu-filter-by-version}). +This prompts first for one of the qualifiers @samp{<}, @samp{>} or +@samp{=}, and then a package version, and shows packages that has a +lower, equal or higher version than the one specified. + +@item / m +@kindex / m @r{(Package Menu)} +@findex package-menu-filter-marked +Filter package list by non-empty mark (@code{package-menu-filter-marked}). +This shows only the packages that have been marked to be installed or deleted. + +@item / / +@kindex / / @r{(Package Menu)} +@findex package-menu-filter-clear +Clear filter currently applied to the package list +(@code{package-menu-filter-clear}). @end table @noindent diff --git a/doc/emacs/programs.texi b/doc/emacs/programs.texi index b976f2e7b12..1c33d7dccc7 100644 --- a/doc/emacs/programs.texi +++ b/doc/emacs/programs.texi @@ -1269,9 +1269,29 @@ information whenever there is a Lisp function or variable at point; for a function, it shows the argument list, and for a variable it shows the first line of the variable's documentation string. To toggle ElDoc mode, type @kbd{M-x eldoc-mode}. There's also a Global -ElDoc mode, which is turned on by default, and affects buffers, such -as @samp{*scratch*}, whose major mode is Emacs Lisp or Lisp -Interaction (@w{@kbd{M-x global-eldoc-mode}} to turn it off globally). +ElDoc mode, which is turned on by default, and affects buffers whose +major mode sets the variables described below. Use @w{@kbd{M-x +global-eldoc-mode}} to turn it off globally. + +@vindex eldoc-documentation-strategy +@vindex eldoc-documentation-functions + These variables can be used to configure ElDoc mode: + +@table @code +@item eldoc-documentation-strategy +This variable holds the function which is used to retrieve +documentation for the item at point from the functions in the hook +@code{eldoc-documentation-functions}. By default, +@code{eldoc-documentation-strategy} returns the first documentation +string produced by the @code{eldoc-documentation-functions} hook, but +it may be customized to compose those functions' results in other +ways. + +@item eldoc-documentation-functions +This abnormal hook holds documentation functions. It acts as a +collection of backends for ElDoc. This is what modes should use to +register their documentation functions with ElDoc. +@end table @node Hideshow @section Hideshow minor mode diff --git a/doc/emacs/windows.texi b/doc/emacs/windows.texi index 4c67660b92d..bc1dcd7f419 100644 --- a/doc/emacs/windows.texi +++ b/doc/emacs/windows.texi @@ -251,9 +251,19 @@ Mail}), but in another window (@code{compose-mail-other-window}). Find the definition of an identifier, similar to @kbd{M-.} (@pxref{Xref}), but in another window (@code{xref-find-definitions-other-window}). + @item C-x 4 r @var{filename} @key{RET} Visit file @var{filename} read-only, and select its buffer in another window (@code{find-file-read-only-other-window}). @xref{Visiting}. + +@item C-x 4 4 +A more general prefix command affects the buffer displayed by the next +command invoked immediately after this prefix command. It requests +the buffer of the next command to be displayed in another window. + +@item C-x 4 1 +This general prefix command requests the buffer of the next command +to be displayed in the same window. @end table @node Change Window diff --git a/doc/lispintro/emacs-lisp-intro.texi b/doc/lispintro/emacs-lisp-intro.texi index 46462162ca0..f6dd77a3d96 100644 --- a/doc/lispintro/emacs-lisp-intro.texi +++ b/doc/lispintro/emacs-lisp-intro.texi @@ -929,7 +929,7 @@ GNU Emacs Lisp is largely inspired by Maclisp, which was written at MIT in the 1960s. It is somewhat inspired by Common Lisp, which became a standard in the 1980s. However, Emacs Lisp is much simpler than Common Lisp. (The standard Emacs distribution contains an optional extensions -file, @file{cl.el}, that adds many Common Lisp features to Emacs Lisp.) +file, @file{cl-lib.el}, that adds many Common Lisp features to Emacs Lisp.) @node Note for Novices @unnumberedsec A Note for Novices diff --git a/doc/lispref/display.texi b/doc/lispref/display.texi index 2ef27c00b8e..25eabd6c3fc 100644 --- a/doc/lispref/display.texi +++ b/doc/lispref/display.texi @@ -1318,12 +1318,6 @@ the buffer specified by @var{buffer-or-name} current for running @var{body}. @end defmac -@defmac with-displayed-buffer-window buffer-or-name action quit-function &rest body -This macro is like @code{with-current-buffer-window} but unlike that -displays the buffer specified by @var{buffer-or-name} @emph{before} -running @var{body}. -@end defmac - A window showing a temporary buffer can be fitted to the size of that buffer using the following mode: @@ -2459,12 +2453,15 @@ Draw a box with lines of width 1, in the foreground color. @item @var{color} Draw a box with lines of width 1, in color @var{color}. -@item @code{(:line-width @var{width} :color @var{color} :style @var{style})} -This way you can explicitly specify all aspects of the box. The value -@var{width} specifies the width of the lines to draw; it defaults to -1. A negative width @minus{}@var{n} means to draw a line of width @var{n} -whose top and bottom parts occupy the space of the underlying text, -thus avoiding any increase in the character height. +@item @code{(:line-width (@var{vwidth} . @var{hwidth}) :color @var{color} :style @var{style})} +This way you can explicitly specify all aspects of the box. The values +@var{vwidth} and @var{hwidth} specifies respectively the width of the +vertical and horizontal lines to draw; they default to (1 . 1). +A negative horizontal or vertical width @minus{}@var{n} means to draw a line +of width @var{n} that occupies the space of the underlying text, thus +avoiding any increase in the character height or width. For simplification +the width could be specified with only a single number @var{n} instead +of a list, such case is equivalent to @code{((abs @var{n}) . @var{n})}. The value @var{color} specifies the color to draw with. The default is the foreground color of the face for simple boxes, and the background diff --git a/doc/lispref/edebug.texi b/doc/lispref/edebug.texi index b5b5ea0a645..d879f3dcadf 100644 --- a/doc/lispref/edebug.texi +++ b/doc/lispref/edebug.texi @@ -1362,6 +1362,11 @@ while matching the remainder of the specifications at this level. This is primarily used to generate more specific syntax error messages. See @ref{Backtracking}, for more details. Also see the @code{let} example. +@item &error +@code{&error} should be followed by a string, an error message, in the +edebug-spec; it aborts the instrumentation, displaying the message in +the minibuffer. + @item @var{other-symbol} @cindex indirect specifications Any other symbol in a specification list may be a predicate or an diff --git a/doc/lispref/files.texi b/doc/lispref/files.texi index 6ca2834fbd4..92cbc2a1c91 100644 --- a/doc/lispref/files.texi +++ b/doc/lispref/files.texi @@ -928,7 +928,7 @@ also checks that the file's group would be unchanged. This function does not follow symbolic links. @end defun -@defun file-modes filename +@defun file-modes filename &optional flag @cindex mode bits @cindex file permissions @cindex permissions, file @@ -946,12 +946,19 @@ The highest possible value is 4095 (7777 octal), meaning that everyone has read, write, and execute permission, the @acronym{SUID} bit is set for both others and group, and the sticky bit is set. +By default this function follows symbolic links. However, if the +optional argument @var{flag} is the symbol @code{nofollow}, this +function does not follow @var{filename} if it is a symbolic link; +this can help prevent inadvertently obtaining the mode bits of a file +somewhere else, and is more consistent with @code{file-attributes} +(@pxref{File Attributes}). + @xref{Changing Files}, for the @code{set-file-modes} function, which can be used to set these permissions. @example @group -(file-modes "~/junk/diffs") +(file-modes "~/junk/diffs" 'nofollow) @result{} 492 ; @r{Decimal integer.} @end group @group @@ -960,7 +967,7 @@ can be used to set these permissions. @end group @group -(set-file-modes "~/junk/diffs" #o666) +(set-file-modes "~/junk/diffs" #o666 'nofollow) @result{} nil @end group @@ -1801,9 +1808,17 @@ See also @code{delete-directory} in @ref{Create/Delete Dirs}. @cindex file permissions, setting @cindex permissions, file @cindex file modes, setting -@deffn Command set-file-modes filename mode +@deffn Command set-file-modes filename mode &optional flag This function sets the @dfn{file mode} (or @dfn{permissions}) of -@var{filename} to @var{mode}. This function follows symbolic links. +@var{filename} to @var{mode}. + +By default this function follows symbolic links. However, if the +optional argument @var{flag} is the symbol @code{nofollow}, this +function does not follow @var{filename} if it is a symbolic link; +this can help prevent inadvertently changing the mode bits of a file +somewhere else. On platforms that do not support changing mode bits +on a symbolic link, this function signals an error when @var{filename} +is a symbolic link and @var{flag} is @code{nofollow}. If called non-interactively, @var{mode} must be an integer. Only the lowest 12 bits of the integer are used; on most systems, only the @@ -1811,7 +1826,7 @@ lowest 9 bits are meaningful. You can use the Lisp construct for octal numbers to enter @var{mode}. For example, @example -(set-file-modes #o644) +(set-file-modes "myfile" #o644 'nofollow) @end example @noindent @@ -1894,11 +1909,24 @@ omitted or @code{nil}, it defaults to 0, i.e., no access rights at all. @end defun -@defun set-file-times filename &optional time +@defun file-modes-number-to-symbolic modes +This function converts a numeric file mode specification in +@var{modes} into the equivalent symbolic form. +@end defun + +@defun set-file-times filename &optional time flag This function sets the access and modification times of @var{filename} to @var{time}. The return value is @code{t} if the times are successfully set, otherwise it is @code{nil}. @var{time} defaults to the current time and must be a time value (@pxref{Time of Day}). + +By default this function follows symbolic links. However, if the +optional argument @var{flag} is the symbol @code{nofollow}, this +function does not follow @var{filename} if it is a symbolic link; +this can help prevent inadvertently changing the times of a file +somewhere else. On platforms that do not support changing times +on a symbolic link, this function signals an error when @var{filename} +is a symbolic link and @var{flag} is @code{nofollow}. @end defun @defun set-file-extended-attributes filename attribute-alist diff --git a/doc/lispref/frames.texi b/doc/lispref/frames.texi index ae61b269520..22d32c00d9b 100644 --- a/doc/lispref/frames.texi +++ b/doc/lispref/frames.texi @@ -2193,10 +2193,11 @@ it and see if it works.) @vindex ns-appearance@r{, a frame parameter} @item ns-appearance Only available on macOS, if set to @code{dark} draw this frame's -window-system window using the ``vibrant dark'' theme, otherwise use -the system default. The ``vibrant dark'' theme can be used to set the -toolbar and scrollbars to a dark appearance when using an Emacs theme -with a dark background. +window-system window using the ``vibrant dark'' theme, and if set to +@code{light} use the ``aqua'' theme, otherwise use the system default. +The ``vibrant dark'' theme can be used to set the toolbar and +scrollbars to a dark appearance when using an Emacs theme with a dark +background. @vindex ns-transparent-titlebar@r{, a frame parameter} @item ns-transparent-titlebar @@ -2220,6 +2221,9 @@ How to display the cursor. Legitimate values are: @table @code @item box Display a filled box. (This is the default.) +@item (box . @var{size}) +Display a filled box. However, display it as a hollow box if point is +under masked image larger than @var{size} pixels in either dimension. @item hollow Display a hollow box. @item nil @@ -3872,13 +3876,15 @@ detailed knowledge of what types other applications use for drag and drop. @vindex dnd-protocol-alist +@vindex browse-url-handlers +@vindex browse-url-default-handlers When an URL is dropped on Emacs it may be a file, but it may also be another URL type (https, etc.). Emacs first checks @code{dnd-protocol-alist} to determine what to do with the URL@. If -there is no match there and if @code{browse-url-browser-function} is -an alist, Emacs looks for a match there. If no match is found the -text for the URL is inserted. If you want to alter Emacs behavior, -you can customize these variables. +there is no match there, Emacs looks for a match in +@code{browse-url-handlers} and @code{browse-url-default-handlers}. If +still no match has been found, the text for the URL is inserted. If +you want to alter Emacs behavior, you can customize these variables. @node Color Names @section Color Names @@ -3970,11 +3976,11 @@ If @var{color} is not defined, the value is @code{nil}. (color-values "black") @result{} (0 0 0) (color-values "white") - @result{} (65280 65280 65280) + @result{} (65535 65535 65535) (color-values "red") - @result{} (65280 0 0) + @result{} (65535 0 0) (color-values "pink") - @result{} (65280 49152 51968) + @result{} (65535 49344 52171) (color-values "hungry") @result{} nil @end example diff --git a/doc/lispref/internals.texi b/doc/lispref/internals.texi index 325841d8f8a..d70c3543f2a 100644 --- a/doc/lispref/internals.texi +++ b/doc/lispref/internals.texi @@ -1228,9 +1228,9 @@ the @var{runtime} structure with the value compiled into the module: @example int -emacs_module_init (struct emacs_runtime *ert) +emacs_module_init (struct emacs_runtime *runtime) @{ - if (ert->size < sizeof (*ert)) + if (runtime->size < sizeof (*runtime)) return 1; @} @end example @@ -1247,7 +1247,7 @@ assumes it is part of the @code{emacs_module_init} function shown above: @example - emacs_env *env = ert->get_environment (ert); + emacs_env *env = runtime->get_environment (runtime); if (env->size < sizeof (*env)) return 2; @end example @@ -1264,7 +1264,7 @@ Emacs, by comparing the size of the environment passed by Emacs with known sizes, like this: @example - emacs_env *env = ert->get_environment (ert); + emacs_env *env = runtime->get_environment (runtime); if (env->size >= sizeof (struct emacs_env_26)) emacs_version = 26; /* Emacs 26 or later. */ else if (env->size >= sizeof (struct emacs_env_25)) @@ -1314,7 +1314,8 @@ subsection describes how to write such @dfn{module functions}. A module function has the following general form and signature: -@deftypefn Function emacs_value module_func (emacs_env *@var{env}, ptrdiff_t @var{nargs}, emacs_value *@var{args}, void *@var{data}) +@deftypefn Function emacs_value emacs_function (emacs_env *@var{env}, ptrdiff_t @var{nargs}, emacs_value *@var{args}, void *@var{data}) +@tindex emacs_function The @var{env} argument provides a pointer to the @acronym{API} environment, needed to access Emacs objects and functions. The @var{nargs} argument is the required number of arguments, which can be @@ -1323,7 +1324,7 @@ of the argument number), and @var{args} is a pointer to the array of the function arguments. The argument @var{data} points to additional data required by the function, which was arranged when @code{make_function} (see below) was called to create an Emacs -function from @code{module_func}. +function from @code{emacs_function}. Module functions use the type @code{emacs_value} to communicate Lisp objects between Emacs and the module (@pxref{Module Values}). The @@ -1338,6 +1339,10 @@ However, if the user typed @kbd{C-g}, or if the module function or its callees signaled an error or exited nonlocally (@pxref{Module Nonlocal}), Emacs will ignore the returned value and quit or throw as it does when Lisp code encounters the same situations. + +The header @file{emacs-module.h} provides the type +@code{emacs_function} as an alias type for a function pointer to a +module function. @end deftypefn After writing your C code for a module function, you should make a @@ -1348,11 +1353,11 @@ normally done in the module initialization function (@pxref{module initialization function}), after verifying the @acronym{API} compatibility. -@deftypefn Function emacs_value make_function (emacs_env *@var{env}, ptrdiff_t @var{min_arity}, ptrdiff_t @var{max_arity}, subr @var{func}, const char *@var{docstring}, void *@var{data}) +@deftypefn Function emacs_value make_function (emacs_env *@var{env}, ptrdiff_t @var{min_arity}, ptrdiff_t @var{max_arity}, emacs_function @var{func}, const char *@var{docstring}, void *@var{data}) @vindex emacs_variadic_function This returns an Emacs function created from the C function @var{func}, -whose signature is as described for @code{module_func} above (assumed -here to be @code{typedef}'ed as @code{subr}). The arguments +whose signature is as described for @code{emacs_function} above. +The arguments @var{min_arity} and @var{max_arity} specify the minimum and maximum number of arguments that @var{func} can accept. The @var{max_arity} argument can have the special value @code{emacs_variadic_function}, @@ -1388,7 +1393,7 @@ Combining the above steps, code that arranges for a C function look like this, as part of the module initialization function: @example - emacs_env *env = ert->get_environment (ert); + emacs_env *env = runtime->get_environment (runtime); emacs_value func = env->make_function (env, min_arity, max_arity, module_func, docstring, data); emacs_value symbol = env->intern (env, "module-func"); @@ -1442,6 +1447,54 @@ The Lisp package which goes with your module could then load the module using the @code{load} primitive (@pxref{Dynamic Modules}) when the package is loaded into Emacs. +@anchor{Module Function Finalizers} +If you want to run some code when a module function object (i.e., an +object returned by @code{make_function}) is garbage-collected, you can +install a @dfn{function finalizer}. Function finalizers are available +since Emacs 28. For example, if you have passed some heap-allocated +structure to the @var{data} argument of @code{make_function}, you can +use the finalizer to deallocate the structure. @xref{Basic +Allocation,,,libc}, and @pxref{Freeing after Malloc,,,libc}. The +finalizer function has the following signature: + +@example +void finalizer (void *@var{data}) +@end example + +Here, @var{data} receives the value passed to @var{data} when calling +@code{make_function}. Note that the finalizer can't interact with +Emacs in any way. + +Directly after calling @code{make_function}, the newly-created +function doesn't have a finalizer. Use @code{set_function_finalizer} +to add one, if desired. + +@deftypefun void emacs_finalizer (void *@var{ptr}) +The header @file{emacs-module.h} provides the type +@code{emacs_finalizer} as a type alias for an Emacs finalizer +function. +@end deftypefun + +@deftypefun emacs_finalizer get_function_finalizer (emacs_env *@var{env}, emacs_value @var{arg}) +This function, which is available since Emacs 28, returns the function +finalizer associated with the module function represented by +@var{arg}. @var{arg} must refer to a module function, that is, an +object returned by @code{make_function}. If no finalizer is +associated with the function, @code{NULL} is returned. +@end deftypefun + +@deftypefun void set_function_finalizer (emacs_env *@var{env}, emacs_value @var{arg}, emacs_finalizer @var{fin}) +This function, which is available since Emacs 28, sets the function +finalizer associated with the module function represented by @var{arg} +to @var{fin}. @var{arg} must refer to a module function, that is, an +object returned by @code{make_function}. @var{fin} can either be +@code{NULL} to clear @var{arg}'s function finalizer, or a pointer to a +function to be called when the object represented by @var{arg} is +garbage-collected. At most one function finalizer can be set per +function; if @var{arg} already has a finalizer, it is replaced by +@var{fin}. +@end deftypefun + @node Module Values @subsection Conversion Between Lisp and Module Values @cindex module values, conversion @@ -1541,12 +1594,11 @@ This function returns the value of a Lisp float specified by @var{arg}, as a C @code{double} value. @end deftypefn -@deftypefn Function struct timespec extract_time (emacs_env *@var{env}, emacs_value @var{time}) -This function, which is available since Emacs 27, interprets -@var{time} as an Emacs Lisp time value and returns the corresponding -@code{struct timespec}. @xref{Time of Day}. @code{struct timespec} -represents a timestamp with nanosecond precision. It has the -following members: +@deftypefn Function struct timespec extract_time (emacs_env *@var{env}, emacs_value @var{arg}) +This function, which is available since Emacs 27, interprets @var{arg} +as an Emacs Lisp time value and returns the corresponding @code{struct +timespec}. @xref{Time of Day}. @code{struct timespec} represents a +timestamp with nanosecond precision. It has the following members: @table @code @item time_t tv_sec @@ -1744,9 +1796,9 @@ next_prime (emacs_env *env, ptrdiff_t nargs, emacs_value *args, @} int -emacs_module_init (struct emacs_runtime *ert) +emacs_module_init (struct emacs_runtime *runtime) @{ - emacs_env *env = ert->get_environment (ert); + emacs_env *env = runtime->get_environment (runtime); emacs_value symbol = env->intern (env, "next-prime"); emacs_value func = env->make_function (env, 1, 1, next_prime, NULL, NULL); @@ -1773,16 +1825,15 @@ there's no requirement that @var{time} be normalized. This means that @code{@var{time}.tv_nsec} can be negative or larger than 999,999,999. @end deftypefn -@deftypefn Function emacs_value make_string (emacs_env *@var{env}, const char *@var{str}, ptrdiff_t @var{strlen}) +@deftypefn Function emacs_value make_string (emacs_env *@var{env}, const char *@var{str}, ptrdiff_t @var{len}) This function creates an Emacs string from C text string pointed by @var{str} whose length in bytes, not including the terminating null -byte, is @var{strlen}. The original string in @var{str} can be either -an @acronym{ASCII} string or a UTF-8 encoded non-@acronym{ASCII} -string; it can include embedded null bytes, and doesn't have to end in -a terminating null byte at @code{@var{str}[@var{strlen}]}. The -function raises the @code{overflow-error} error condition if -@var{strlen} is negative or exceeds the maximum length of an Emacs -string. +byte, is @var{len}. The original string in @var{str} can be either an +@acronym{ASCII} string or a UTF-8 encoded non-@acronym{ASCII} string; +it can include embedded null bytes, and doesn't have to end in a +terminating null byte at @code{@var{str}[@var{len}]}. The function +raises the @code{overflow-error} error condition if @var{len} is +negative or exceeds the maximum length of an Emacs string. @end deftypefn The @acronym{API} does not provide functions to manipulate Lisp data @@ -1839,27 +1890,32 @@ garbage-collected. Don't run any expensive code in a finalizer, because GC must finish quickly to keep Emacs responsive. @end deftypefn -@deftypefn Function void *get_user_ptr (emacs_env *@var{env}, emacs_value val) +@deftypefn Function void *get_user_ptr (emacs_env *@var{env}, emacs_value @var{arg}) This function extracts the C pointer from the Lisp object represented -by @var{val}. +by @var{arg}. @end deftypefn -@deftypefn Function void set_user_ptr (emacs_env *@var{env}, emacs_value @var{value}, void *@var{ptr}) +@deftypefn Function void set_user_ptr (emacs_env *@var{env}, emacs_value @var{arg}, void *@var{ptr}) This function sets the C pointer embedded in the @code{user-ptr} -object represented by @var{value} to @var{ptr}. +object represented by @var{arg} to @var{ptr}. @end deftypefn -@deftypefn Function emacs_finalizer get_user_finalizer (emacs_env *@var{env}, emacs_value val) +@deftypefn Function emacs_finalizer get_user_finalizer (emacs_env *@var{env}, emacs_value @var{arg}) This function returns the finalizer of the @code{user-ptr} object -represented by @var{val}, or @code{NULL} if it doesn't have a finalizer. +represented by @var{arg}, or @code{NULL} if it doesn't have a +finalizer. @end deftypefn -@deftypefn Function void set_user_finalizer (emacs_env *@var{env}, emacs_value @var{val}, emacs_finalizer @var{fin}) +@deftypefn Function void set_user_finalizer (emacs_env *@var{env}, emacs_value @var{arg}, emacs_finalizer @var{fin}) This function changes the finalizer of the @code{user-ptr} object -represented by @var{val} to be @var{fin}. If @var{fin} is a -@code{NULL} pointer, the @code{user-ptr} object will have no finalizer. +represented by @var{arg} to be @var{fin}. If @var{fin} is a +@code{NULL} pointer, the @code{user-ptr} object will have no +finalizer. @end deftypefn +Note that the @code{emacs_finalizer} type works for both user pointer +an module function finalizers. @xref{Module Function Finalizers}. + @node Module Misc @subsection Miscellaneous Convenience Functions for Modules @@ -1870,20 +1926,20 @@ be called via the @code{emacs_env} pointer. Description of functions that were introduced after Emacs 25 calls out the first version where they became available. -@deftypefn Function bool eq (emacs_env *@var{env}, emacs_value @var{val1}, emacs_value @var{val2}) +@deftypefn Function bool eq (emacs_env *@var{env}, emacs_value @var{a}, emacs_value @var{b}) This function returns @code{true} if the Lisp objects represented by -@var{val1} and @var{val2} are identical, @code{false} otherwise. This -is the same as the Lisp function @code{eq} (@pxref{Equality -Predicates}), but avoids the need to intern the objects represented by -the arguments. +@var{a} and @var{b} are identical, @code{false} otherwise. This is +the same as the Lisp function @code{eq} (@pxref{Equality Predicates}), +but avoids the need to intern the objects represented by the +arguments. There are no @acronym{API} functions for other equality predicates, so you will need to use @code{intern} and @code{funcall}, described below, to perform more complex equality tests. @end deftypefn -@deftypefn Function bool is_not_nil (emacs_env *@var{env}, emacs_value @var{val}) -This function tests whether the Lisp object represented by @var{val} +@deftypefn Function bool is_not_nil (emacs_env *@var{env}, emacs_value @var{arg}) +This function tests whether the Lisp object represented by @var{arg} is non-@code{nil}; it returns @code{true} or @code{false} accordingly. Note that you could implement an equivalent test by using @@ -1892,12 +1948,12 @@ then use @code{eq}, described above, to test for equality. But using this function is more convenient. @end deftypefn -@deftypefn Function emacs_value type_of (emacs_env *@var{env}, emacs_value @code{object}) -This function returns the type of @var{object} as a value that -represents a symbol: @code{string} for a string, @code{integer} for an -integer, @code{process} for a process, etc. @xref{Type Predicates}. -You can use @code{intern} and @code{eq} to compare against known type -symbols, if your code needs to depend on the object type. +@deftypefn Function emacs_value type_of (emacs_env *@var{env}, emacs_value @code{arg}) +This function returns the type of @var{arg} as a value that represents +a symbol: @code{string} for a string, @code{integer} for an integer, +@code{process} for a process, etc. @xref{Type Predicates}. You can +use @code{intern} and @code{eq} to compare against known type symbols, +if your code needs to depend on the object type. @end deftypefn @anchor{intern} @@ -1917,8 +1973,7 @@ calling the more powerful Emacs @code{intern} function emacs_value fintern = env->intern (env, "intern"); emacs_value sym_name = env->make_string (env, name_str, strlen (name_str)); -emacs_value intern_args[] = @{ sym_name, env->intern (env, "nil") @}; -emacs_value symbol = env->funcall (env, fintern, 2, intern_args); +emacs_value symbol = env->funcall (env, fintern, 1, &sym_name); @end example @end deftypefn @@ -1967,6 +2022,20 @@ variable values and buffer content may have been modified in arbitrary ways. @end deftypefn +@anchor{open_channel} +@deftypefun int open_channel (emacs_env *@var{env}, emacs_value @var{pipe_process}) +This function, which is available since Emacs 28, opens a channel to +an existing pipe process. @var{pipe_process} must refer to an +existing pipe process created by @code{make-pipe-process}. @ref{Pipe +Processes}. If successful, the return value will be a new file +descriptor that you can use to write to the pipe. Unlike all other +module functions, you can use the returned file descriptor from +arbitrary threads, even if no module environment is active. You can +use the @code{write} function to write to the file descriptor. Once +done, close the file descriptor using @code{close}. @ref{Low-Level +I/O,,,libc}. +@end deftypefun + @node Module Nonlocal @subsection Nonlocal Exits in Modules @cindex nonlocal exits, in modules @@ -2071,11 +2140,12 @@ One use of this function is when you want to re-throw a non-local exit from one of the called @acronym{API} or Lisp functions. @end deftypefn -@deftypefn Function void non_local_exit_signal (emacs_env *@var{env}, emacs_value @var{error}, emacs_value @var{data}) -This function signals the error represented by @var{error} with the -specified error data @var{data}. The module function should return -soon after calling this function. This function could be useful, -e.g., for signaling errors from module functions to Emacs. +@deftypefn Function void non_local_exit_signal (emacs_env *@var{env}, emacs_value @var{symbol}, emacs_value @var{data}) +This function signals the error represented by the error symbol +@var{symbol} with the specified error data @var{data}. The module +function should return soon after calling this function. This +function could be useful, e.g., for signaling errors from module +functions to Emacs. @end deftypefn diff --git a/doc/lispref/keymaps.texi b/doc/lispref/keymaps.texi index 1e81fb1dc52..130ff0d8671 100644 --- a/doc/lispref/keymaps.texi +++ b/doc/lispref/keymaps.texi @@ -1846,8 +1846,11 @@ local map. @cindex scanning keymaps @cindex keymaps, scanning - This section describes functions used to scan all the current keymaps -for the sake of printing help information. + This section describes functions used to scan all the current +keymaps for the sake of printing help information. To display the +bindings in a particular keymap, you can use the +@code{describe-keymap} command (@pxref{Misc Help, , Other Help +Commands, emacs, The GNU Emacs Manual}) @defun accessible-keymaps keymap &optional prefix This function returns a list of all the keymaps that can be reached (via diff --git a/doc/lispref/loading.texi b/doc/lispref/loading.texi index 2739d10ece9..6833af9c262 100644 --- a/doc/lispref/loading.texi +++ b/doc/lispref/loading.texi @@ -1170,10 +1170,13 @@ extension, a.k.a.@: ``suffix''. This suffix is platform-dependent. @defvar module-file-suffix This variable holds the system-dependent value of the file-name -extension of the module files. Its value is @file{.so} on POSIX hosts -and @file{.dll} on MS-Windows. +extension of the module files. Its value is @file{.so} on POSIX +hosts, @file{.dylib} on macOS, and @file{.dll} on MS-Windows. @end defvar + On macOS, dynamic modules can also have the suffix @file{.so} in +addition to @file{.dylib}. + @findex emacs_module_init @vindex plugin_is_GPL_compatible Every dynamic module should export a C-callable function named diff --git a/doc/lispref/minibuf.texi b/doc/lispref/minibuf.texi index c1615993f5e..2488fb37529 100644 --- a/doc/lispref/minibuf.texi +++ b/doc/lispref/minibuf.texi @@ -646,6 +646,15 @@ A history list for variable-name arguments read by @code{read-variable}. @end defvar +@defvar read-number-history +A history list for numbers read by @code{read-number}. +@end defvar + +@defvar goto-line-history +A history list for arguments to @code{goto-line}. This variable is +buffer local. +@end defvar + @c Less common: coding-system-history, input-method-history, @c command-history, grep-history, grep-find-history, @c read-envvar-name-history, setenv-history, yes-or-no-p-history. diff --git a/doc/lispref/modes.texi b/doc/lispref/modes.texi index e685391c955..33a07c9fb4d 100644 --- a/doc/lispref/modes.texi +++ b/doc/lispref/modes.texi @@ -469,9 +469,10 @@ variable @code{imenu-generic-expression}, for the two variables @code{imenu-create-index-function} (@pxref{Imenu}). @item -The mode can specify a local value for -@code{eldoc-documentation-function} to tell ElDoc mode how to handle -this mode. +The mode can tell ElDoc mode how to retrieve different types of +documentation for whatever is at point, by adding one or more +buffer-local entries to the special hook +@code{eldoc-documentation-functions}. @item The mode can specify how to complete various keywords by adding one or @@ -1352,19 +1353,11 @@ illustrate how these modes are written. @end smallexample The three modes for Lisp share much of their code. For instance, -each calls the following function to set various variables: - -@smallexample -@group -(defun lisp-mode-variables (&optional syntax keywords-case-insensitive elisp) - (when syntax - (set-syntax-table lisp-mode-syntax-table)) - @dots{} -@end group -@end smallexample +Lisp mode and Emacs Lisp mode inherit from Lisp Data mode and Lisp +Interaction Mode inherits from Emacs Lisp mode. @noindent -Amongst other things, this function sets up the @code{comment-start} +Amongst other things, Lisp Data mode sets up the @code{comment-start} variable to handle Lisp comments: @smallexample @@ -1414,7 +1407,7 @@ Finally, here is the major mode command for Lisp mode: @smallexample @group -(define-derived-mode lisp-mode prog-mode "Lisp" +(define-derived-mode lisp-mode lisp-data-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -1425,10 +1418,9 @@ Note that `run-lisp' may be used either to start an inferior Lisp job or to switch back to an existing one." @end group @group - (lisp-mode-variables nil t) (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") (setq imenu-case-fold-search t)) @end group @end smallexample @@ -2673,6 +2665,7 @@ Setting this variable makes it buffer-local in the current buffer. @node Font Lock Mode @section Font Lock Mode @cindex Font Lock mode +@cindex syntax highlighting and coloring @dfn{Font Lock mode} is a buffer-local minor mode that automatically attaches @code{face} properties to certain parts of the buffer based on diff --git a/doc/lispref/objects.texi b/doc/lispref/objects.texi index 5c5f89eb433..83066744121 100644 --- a/doc/lispref/objects.texi +++ b/doc/lispref/objects.texi @@ -2339,8 +2339,12 @@ same sequence of character codes and all these codes are in the range @end group @end example -However, two distinct buffers are never considered @code{equal}, even if -their textual contents are the same. +The @code{equal} function recursively compares the contents of objects +if they are integers, strings, markers, vectors, bool-vectors, +byte-code function objects, char-tables, records, or font objects. +Other objects are considered @code{equal} only if they are @code{eq}. +For example, two distinct buffers are never considered @code{equal}, +even if their textual contents are the same. @end defun For @code{equal}, equality is defined recursively; for example, given diff --git a/doc/lispref/os.texi b/doc/lispref/os.texi index b31ab87ff17..942bda105f7 100644 --- a/doc/lispref/os.texi +++ b/doc/lispref/os.texi @@ -1701,7 +1701,8 @@ following form: @noindent The format of this list is the same as what @code{decode-time} accepts (@pxref{Time Conversion}), and is described in more detail there. Any -element that cannot be determined from the input will be set to +@code{dst} element that cannot be determined from the input is set to +@minus{}1, and any other unknown element is set to @code{nil}. The argument @var{string} should resemble an RFC 822 (or later) or ISO 8601 string, like ``Fri, 25 Mar 2016 16:24:56 +0100'' or ``1998-09-12T12:21:54-0200'', but this function will attempt to parse @@ -2193,9 +2194,9 @@ cause anything special to happen. @findex list-timers The @code{list-timers} command lists all the currently active timers. -There's only one command available in the buffer displayed: @kbd{c} -(@code{timer-list-cancel}) that will cancel the timer on the line -under point. +The command @kbd{c} (@code{timer-list-cancel}) will cancel the timer +on the line under point. You can sort the list by column using the +command @kbd{S} (@code{tabulated-list-sort}). @node Idle Timers @section Idle Timers @@ -3137,7 +3138,7 @@ being reported. For example: @end group @group -(set-file-modes "/tmp/foo" (default-file-modes)) +(set-file-modes "/tmp/foo" (default-file-modes) 'nofollow) @result{} Event (35025468 attribute-changed "/tmp/foo") @end group @end example diff --git a/doc/lispref/processes.texi b/doc/lispref/processes.texi index 6970f718ee0..4002004cd6f 100644 --- a/doc/lispref/processes.texi +++ b/doc/lispref/processes.texi @@ -477,6 +477,22 @@ You should only ever change this variable with a let-binding; never with @code{setq}. @end defvar +@defopt process-file-return-signal-string +This user option indicates whether a call of @code{process-file} +returns a string describing the signal interrupting a remote process. + +When a process returns an exit code greater than 128, it is +interpreted as a signal. @code{process-file} requires to return a +string describing this signal. + +Since there are processes violating this rule, returning exit codes +greater than 128 which are not bound to a signal, @code{process-file} +returns always the exit code as natural number for remote processes. +Setting this user option to non-nil forces @code{process-file} to +interpret such exit codes as signals, and to return a corresponding +string. +@end defopt + @defun call-process-region start end program &optional delete destination display &rest args This function sends the text from @var{start} to @var{end} as standard input to a process running @var{program}. It deletes the text @@ -743,6 +759,7 @@ Some file name handlers may not support @code{make-process}. In such cases, this function does nothing and returns @code{nil}. @end defun +@anchor{Pipe Processes} @defun make-pipe-process &rest args This function creates a bidirectional pipe which can be attached to a child process. This is useful with the @code{:stderr} keyword of @@ -2426,18 +2443,15 @@ server is stopped; a non-@code{nil} value means yes. @cindex encrypted network connections @cindex @acronym{TLS} network connections @cindex @acronym{STARTTLS} network connections -Emacs can create encrypted network connections, using either built-in -or external support. The built-in support uses the GnuTLS -Transport Layer Security Library; see +Emacs can create encrypted network connections, using the built-in +support for the GnuTLS Transport Layer Security Library; see @uref{https://www.gnu.org/software/gnutls/, the GnuTLS project page}. If your Emacs was compiled with GnuTLS support, the function @code{gnutls-available-p} is defined and returns non-@code{nil}. For more details, @pxref{Top,, Overview, emacs-gnutls, The Emacs-GnuTLS manual}. -The external support uses the @file{starttls.el} library, which -requires a helper utility such as @command{gnutls-cli} to be installed -on the system. The @code{open-network-stream} function can -transparently handle the details of creating encrypted connections for -you, using whatever support is available. +The @code{open-network-stream} function can transparently handle the +details of creating encrypted connections for you, using whatever +support is available. @defun open-network-stream name buffer host service &rest parameters This function opens a TCP connection, with optional encryption, and @@ -2465,6 +2479,12 @@ that are mainly relevant to encrypted connections: @item :nowait @var{boolean} If non-@code{nil}, try to make an asynchronous connection. +@item :coding @var{coding} +Use this to set the coding systems used by the network process, in +preference to binding @code{coding-system-for-read} or +@code{coding-system-for-write}. @xref{Network Processes}, for +details. + @item :type @var{type} The type of connection. Options are: @@ -2491,7 +2511,10 @@ If non-@code{nil}, always ask for the server's capabilities, even when doing a @samp{plain} connection. @item :capability-command @var{capability-command} -Command string to query the host capabilities. +Command to query the host capabilities. This can either be a string +(which will then be sent verbatim to the server), or a function +(called with a single parameter; the "greeting" from the server when +connecting), and should return a string. @item :end-of-command @var{regexp} @itemx :end-of-capability @var{regexp} diff --git a/doc/lispref/searching.texi b/doc/lispref/searching.texi index 83c154938cd..c8a12bdd66b 100644 --- a/doc/lispref/searching.texi +++ b/doc/lispref/searching.texi @@ -338,16 +338,14 @@ first tries to match all three @samp{a}s; but the rest of the pattern is The next alternative is for @samp{a*} to match only two @samp{a}s. With this choice, the rest of the regexp matches successfully. -@strong{Warning:} Nested repetition operators can run for an -indefinitely long time, if they lead to ambiguous matching. For +@strong{Warning:} Nested repetition operators can run for a very +long time, if they lead to ambiguous matching. For example, trying to match the regular expression @samp{\(x+y*\)*a} against the string @samp{xxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxxz} could take hours before it ultimately fails. Emacs must try each way of grouping the @samp{x}s before concluding that none of them can work. -Even worse, @samp{\(x*\)*} can match the null string in infinitely -many ways, so it causes an infinite loop. To avoid these problems, -check nested repetitions carefully, to make sure that they do not -cause combinatorial explosions in backtracking. +In general, avoid expressions that can match the same string in +multiple ways. @item @samp{+} @cindex @samp{+} in regexp diff --git a/doc/lispref/strings.texi b/doc/lispref/strings.texi index 0dc47f30c43..8de6255478b 100644 --- a/doc/lispref/strings.texi +++ b/doc/lispref/strings.texi @@ -1157,7 +1157,7 @@ The function @code{format-spec} described in this section performs a similar function to @code{format}, except it operates on format control strings that use arbitrary specification characters. -@defun format-spec template spec-alist &optional only-present +@defun format-spec template spec-alist &optional ignore-missing This function returns a string produced from the format string @var{template} according to conversions specified in @var{spec-alist}, which is an alist (@pxref{Association Lists}) of the form @@ -1190,12 +1190,15 @@ The order of specifications in @var{template} need not correspond to the order of associations in @var{spec-alist}. @end itemize -The optional argument @var{only-present} indicates how to handle +The optional argument @var{ignore-missing} indicates how to handle specification characters in @var{template} that are not found in @var{spec-alist}. If it is @code{nil} or omitted, the function -signals an error. Otherwise, those format specifications and any -occurrences of @samp{%%} in @var{template} are left verbatim in the -output, including their text properties, if any. +signals an error; if it is @code{ignore}, those format specifications +are left verbatim in the output, including their text properties, if +any; if it is @code{delete}, those format specifications are removed +from the output; any other non-@code{nil} value is handled like +@code{ignore}, but any occurrences of @samp{%%} are also left verbatim +in the output. @end defun The syntax of format specifications accepted by @code{format-spec} is @@ -1243,7 +1246,7 @@ the right rather than the left. @item < This flag causes the substitution to be truncated on the left to the -given width, if specified. +given width and precision, if specified. @item > This flag causes the substitution to be truncated on the right to the @@ -1262,9 +1265,12 @@ The result of using contradictory flags (for instance, both upper and lower case) is undefined. As is the case with @code{format}, a format specification can include -a width, which is a decimal number that appears after any flags. If a -substitution contains fewer characters than its specified width, it is -padded on the left: +a width, which is a decimal number that appears after any flags, and a +precision, which is a decimal-point @samp{.} followed by a decimal +number that appears after any flags and width. + +If a substitution contains fewer characters than its specified width, +it is padded on the left: @example @group @@ -1274,6 +1280,17 @@ padded on the left: @end group @end example +If a substitution contains more characters than its specified +precision, it is truncated on the right: + +@example +@group +(format-spec "%.2a is truncated on the right" + '((?a . "alpha"))) + @result{} "al is truncated on the right" +@end group +@end example + Here is a more complicated example that combines several aforementioned features: diff --git a/doc/lispref/text.texi b/doc/lispref/text.texi index 5d83e7bd6cc..0c3813ff1d0 100644 --- a/doc/lispref/text.texi +++ b/doc/lispref/text.texi @@ -4813,11 +4813,9 @@ When @var{noerror} is non-@code{nil}, this function silently uses @code{raw-text} coding instead. @item (@code{iv-auto} @var{length}) -This will generate an IV (Initialization Vector) of the specified -length using the GnuTLS @code{GNUTLS_RND_NONCE} generator and pass it -to the function. This ensures that the IV is unpredictable and -unlikely to be reused in the same session. The actual value of the IV -is returned by the function as described below. +This generates a random IV (Initialization Vector) of the specified +length and passes it to the function. This ensures that the IV is +unpredictable and unlikely to be reused in the same session. @end table @@ -5101,6 +5099,9 @@ The following are functions for altering the @acronym{DOM}. @item dom-set-attribute @var{node} @var{attribute} @var{value} Set the @var{attribute} of the node to @var{value}. +@item dom-remove-attribute @var{node} @var{attribute} +Remove @var{attribute} from @var{node}. + @item dom-append-child @var{node} @var{child} Append @var{child} as the last child of @var{node}. diff --git a/doc/lispref/windows.texi b/doc/lispref/windows.texi index a19f123c658..5ec23a9c876 100644 --- a/doc/lispref/windows.texi +++ b/doc/lispref/windows.texi @@ -3048,6 +3048,16 @@ since there is no guarantee that an arbitrary caller of @code{display-buffer} will be able to handle the case that no window will display the buffer. @code{display-buffer-no-window} is the only action function that cares about this entry. + +@vindex body-function@r{, a buffer display action alist entry} +@item body-function +The value must be a function taking one argument (a displayed window). +This function can be used to fill the displayed window's body with +some contents that might depend on dimensions of the displayed window. +It is called @emph{after} the buffer is displayed, and @emph{before} +the entries @code{window-height}, @code{window-width} and +@code{preserve-size} are applied that could resize the window to fit +it to the inserted contents. @end table By convention, the entries @code{window-height}, @code{window-width} @@ -5916,10 +5926,6 @@ This function compares two window configurations as regards the structure of windows, but ignores the values of point and the saved scrolling positions---it can return @code{t} even if those aspects differ. - -The function @code{equal} can also compare two window configurations; it -regards configurations as unequal if they differ in any respect, even a -saved point. @end defun @defun window-configuration-frame config diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index f9196f808e7..1dab29b8a5a 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -35164,16 +35164,7 @@ which are called at various times. Calc defines a number of hooks that help you to customize it in various ways. Calc uses the Lisp function @code{run-hooks} to invoke the hooks shown below. Several other customization-related variables are also described here. - -@defvar calc-load-hook -This hook is called at the end of @file{calc.el}, after the file has -been loaded, before any functions in it have been called, but after -@code{calc-mode-map} and similar variables have been set up. -@end defvar - -@defvar calc-ext-load-hook -This hook is called at the end of @file{calc-ext.el}. -@end defvar +To run code after Calc has loaded, use @code{with-eval-after-load}. @defvar calc-start-hook This hook is called as the last step in a @kbd{M-x calc} command. diff --git a/doc/misc/cc-mode.texi b/doc/misc/cc-mode.texi index 544ff853351..10bbf8ff09f 100644 --- a/doc/misc/cc-mode.texi +++ b/doc/misc/cc-mode.texi @@ -350,11 +350,12 @@ Line-Up Functions * Misc Line-Up:: -Customizing Macros +Custom Macros * Macro Backslashes:: * Macros with ;:: * Noise Macros:: +* Indenting Directives:: @end detailmenu @end menu @@ -2131,6 +2132,11 @@ For Pike autodoc markup, the standard in Pike. @item gtkdoc @cindex GtkDoc markup For GtkDoc markup, widely used in the Gnome community. + +@item doxygen +@cindex Doxygen markup +For Doxygen markup, which can be used with C, C++, Java and variety of +other languages. @end table The above is by no means complete. If you'd like to see support for @@ -6389,6 +6395,26 @@ function is the same as specifying a list @code{(c-lineup-assignments @comment ------------------------------------------------------------ +@defun c-lineup-ternary-bodies +@findex lineup-ternary-bodies @r{(c-)} +Line up true and false branches of a ternary operator +(i.e. @code{?:}). More precisely, if the line starts with a colon +which is a part of a said operator, align it with corresponding +question mark. For example: + +@example +@group +return arg % 2 == 0 ? arg / 2 + : (3 * arg + 1); @hereFn{c-lineup-ternary-bodies} +@end group +@end example + +@workswith @code{arglist-cont}, @code{arglist-cont-nonempty} and +@code{statement-cont}. +@end defun + +@comment ------------------------------------------------------------ + @defun c-lineup-cascaded-calls @findex lineup-cascaded-calls @r{(c-)} Line up ``cascaded calls'' under each other. If the line begins with @@ -6949,6 +6975,10 @@ is @code{nil}, all lines inside macro definitions are analyzed as @code{cpp-macro-cont}. @end defopt +Sometimes you may want to indent particular directives +(e.g. @code{#pragma}) as though they were statements. To do this, see +@ref{Indenting Directives}. + Because a macro can expand into anything at all, near where one is invoked @ccmode{} can only indent and fontify code heuristically. Sometimes it gets it wrong. Usually you should try to design your @@ -6965,6 +6995,7 @@ Macros}. * Macro Backslashes:: * Macros with ;:: * Noise Macros:: +* Indenting Directives:: @end menu @comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @@ -7074,7 +7105,7 @@ initialization code, after the mode hooks have run. @end defun @comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -@node Noise Macros, , Macros with ;, Custom Macros +@node Noise Macros, Indenting Directives, Macros with ;, Custom Macros @comment node-name, next, previous, up @section Noise Macros @cindex noise macros @@ -7131,6 +7162,48 @@ after the mode hooks have run. @end defun @comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +@node Indenting Directives, , Noise Macros, Custom Macros +@comment node-name, next, previous, up +@section Indenting Directives +@cindex Indenting Directives +@cindex Indenting #pragma +@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +Sometimes you may want to indent particular preprocessor directives +(e.g. @code{#pragma}) as though they were statements. To do this, +first set up @code{c-cpp-indent-to-body-directives} to include the +directive name(s), then enable the ``indent to body'' feature with +@code{c-toggle-cpp-indent-to-body}. + +@defopt c-cpp-indent-to-body-directives +@vindex cpp-indent-to-body-directives (c-) +This variable is a list of names of CPP directives (not including the +introducing @samp{#}) which will be indented as though statements. +Each element is a string, and must be a valid identifier. The default +value is @code{("pragma")}. + +If you add more directives to this variable, or remove directives from +it, whilst ``indent to body'' is active, you need to re-enable the +feature by calling @code{c-toggle-cpp-indent-to-body} for these +changes to take effect@footnote{Note that the removal of directives +doesn't work satisfactorally on XEmacs or on very old versions of +Emacs}. +@end defopt + +@defun c-toggle-cpp-indent-to-body +@findex toggle-cpp-indent-to-body (c-) +With @kbd{M-x c-toggle-cpp-indent-to-body}, you enable or disable the +``indent to body'' feature. When called programmatically, it takes an +optional numerical argument. A positive value will enable the +feature, a zero or negative value will disable it. + +You should set up @code{c-cpp-indent-to-body-directives} before +calling this function, since the function sets internal state which +depends on that variable. +@end defun + + +@comment !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! @node Odds and Ends, Sample Init File, Custom Macros, Top @comment node-name, next, previous, up @chapter Odds and Ends diff --git a/doc/misc/dired-x.texi b/doc/misc/dired-x.texi index 5965da16bb7..d7497806602 100644 --- a/doc/misc/dired-x.texi +++ b/doc/misc/dired-x.texi @@ -185,13 +185,12 @@ In your @file{~/.emacs} file, or in the system-wide initialization file @file{default.el} in the @file{site-lisp} directory, put @example -(add-hook 'dired-load-hook - (lambda () - (load "dired-x") - ;; Set dired-x global variables here. For example: - ;; (setq dired-guess-shell-gnutar "gtar") - ;; (setq dired-x-hands-off-my-keys nil) - )) +(with-eval-after-load 'dired + (require 'dired-x) + ;; Set dired-x global variables here. For example: + ;; (setq dired-guess-shell-gnutar "gtar") + ;; (setq dired-x-hands-off-my-keys nil) + )) (add-hook 'dired-mode-hook (lambda () ;; Set dired-x buffer-local variables here. For example: @@ -242,12 +241,10 @@ If you choose to have @file{dired-x.el} bind @code{dired-x-find-file} over or call @code{dired-x-bind-find-file} after changing the value. @example -(add-hook 'dired-load-hook - (lambda () - ;; Bind dired-x-find-file. - (setq dired-x-hands-off-my-keys nil) - (load "dired-x") - )) +(with-eval-after-load 'dired + ;; Bind dired-x-find-file. + (setq dired-x-hands-off-my-keys nil) + (require 'dired-x)) @end example @node Omitting Files in Dired @@ -294,8 +291,8 @@ Marked files are never omitted. @end table @noindent -In order to make Dired Omit work you first need to load @file{dired-x.el} -inside @code{dired-load-hook} (@pxref{Installation}) and then evaluate +In order to make Dired Omit work you need to load @file{dired-x} +after loading @file{dired} (@pxref{Installation}) and then evaluate @code{(dired-omit-mode 1)} in some way (@pxref{Omitting Variables}). @ifnottex @@ -410,7 +407,7 @@ The default value is @kbd{C-o}. @item @cindex RCS files, how to omit them in Dired @cindex omitting RCS files in Dired -If you wish to avoid seeing RCS files and the @file{RCS} directory, then put +If you wish to avoid seeing RCS files and the @file{RCS} directory, then use @example (setq dired-omit-files @@ -418,7 +415,7 @@ If you wish to avoid seeing RCS files and the @file{RCS} directory, then put @end example @noindent -in the @code{dired-load-hook} (@pxref{Installation}). This assumes +after loading @file{dired-x} (@pxref{Installation}). This assumes @code{dired-omit-localp} has its default value of @code{no-dir} to make the @code{^}-anchored matches work. As a slower alternative, with @code{dired-omit-localp} set to @code{nil}, you can use @code{/} instead of @@ -429,7 +426,7 @@ in the @code{dired-load-hook} (@pxref{Installation}). This assumes @cindex omitting tib files in Dired If you use @code{tib}, the bibliography program for use with @TeX{} and @LaTeX{}, and you -want to omit the @file{INDEX} and the @file{*-t.tex} files, then put +want to omit the @file{INDEX} and the @file{*-t.tex} files, then use @example (setq dired-omit-files @@ -437,13 +434,13 @@ want to omit the @file{INDEX} and the @file{*-t.tex} files, then put @end example @noindent -in the @code{dired-load-hook} (@pxref{Installation}). +after loading @file{dired-x} (@pxref{Installation}). @item @cindex dot files, how to omit them in Dired @cindex omitting dot files in Dired If you do not wish to see @samp{dot} files (files starting with a @file{.}), -then put +then use @example (setq dired-omit-files @@ -451,7 +448,7 @@ then put @end example @noindent -in the @code{dired-load-hook} (@pxref{Installation}). (Of course, a +after loading @file{dired-x} (@pxref{Installation}). (Of course, a better way to achieve this particular goal is simply to omit @samp{-a} from @code{dired-listing-switches}.) @@ -830,7 +827,7 @@ When installed @file{dired-x} will substitute @code{dired-x-find-file} for (normally bound to @kbd{C-x 4 C-f}). In order to use this feature, you will need to set -@code{dired-x-hands-off-my-keys} to @code{nil} inside @code{dired-load-hook} +@code{dired-x-hands-off-my-keys} to @code{nil} before loading @file{dired-x} (@pxref{Optional Installation File At Point}). @table @code diff --git a/doc/misc/ediff.texi b/doc/misc/ediff.texi index 99ba89b0d7f..1ef13716b11 100644 --- a/doc/misc/ediff.texi +++ b/doc/misc/ediff.texi @@ -1197,10 +1197,6 @@ refer to Emacs manual for the information on how to set Emacs X resources. The bulk of customization can be done via the following hooks: @table @code -@item ediff-load-hook -@vindex ediff-load-hook -This hook can be used to change defaults after Ediff is loaded. - @item ediff-before-setup-hook @vindex ediff-before-setup-hook Hook that is run just before Ediff rearranges windows to its liking. @@ -1211,8 +1207,8 @@ Can be used to save windows configuration. @vindex ediff-mode-map This hook can be used to alter bindings in Ediff's keymap, @code{ediff-mode-map}. These hooks are -run right after the default bindings are set but before -@code{ediff-load-hook}. The regular user needs not be concerned with this +run right after the default bindings are set. +The regular user needs not be concerned with this hook---it is provided for implementers of other Emacs packages built on top of Ediff. @@ -1545,12 +1541,13 @@ directly (using @kbd{j}) to any numbered difference. Users can supply their own functions to specify how Ediff should do -selective browsing. To change the default Ediff function, add a function to -@code{ediff-load-hook} which will do the following assignments: +selective browsing. To change the default Ediff function, use +something like the following: @example -(setq ediff-hide-regexp-matches-function 'your-hide-function) -(setq ediff-focus-on-regexp-matches-function 'your-focus-function) +(with-eval-after-load 'ediff + (setq ediff-hide-regexp-matches-function 'your-hide-function) + (setq ediff-focus-on-regexp-matches-function 'your-focus-function)) @end example @strong{Useful hint}: To specify a regexp that matches everything, don't @@ -1728,23 +1725,17 @@ difference region in buffer A (this face is not a good choice, by the way). If you are unhappy with just @emph{some} of the aspects of the default faces, you can modify them when Ediff is being loaded using -@code{ediff-load-hook}. For instance: +@code{with-eval-after-load}. For instance: @smallexample -(add-hook 'ediff-load-hook - (lambda () - (set-face-foreground - ediff-current-diff-face-B "blue") - (set-face-background - ediff-current-diff-face-B "red") - (make-face-italic - ediff-current-diff-face-B))) +(with-eval-after-load 'ediff + (set-face-foreground + ediff-current-diff-face-B "blue") + (set-face-background + ediff-current-diff-face-B "red") + (make-face-italic ediff-current-diff-face-B)) @end smallexample -@strong{Please note:} to set Ediff's faces, use only @code{copy-face} -or @code{set/make-face-@dots{}} as shown above. Emacs's low-level -face-manipulation functions should be avoided. - @node Narrowing @section Narrowing diff --git a/doc/misc/efaq.texi b/doc/misc/efaq.texi index f948a489f44..82467048a08 100644 --- a/doc/misc/efaq.texi +++ b/doc/misc/efaq.texi @@ -1595,6 +1595,10 @@ xterm-direct2 xterm with direct-color indexing (old) xterm-direct xterm with direct-color indexing @end example +If Terminfo database is not available, but 24-bit direct color mode is +supported, it can still be enabled by defining the environment +variable @env{COLORTERM} to @samp{truecolor}. + Terminals with @samp{RGB} capability treat pixels #000001 - #000007 as indexed colors to maintain backward compatibility with applications that are unaware of direct color mode. Therefore the seven darkest @@ -2515,9 +2519,8 @@ To avoid seeing backup files (and other ``uninteresting'' files) in Dired, load @code{dired-x} by adding the following to your @file{.emacs} file: @lisp -(add-hook 'dired-load-hook - (lambda () - (require 'dired-x))) +(with-eval-after-load 'dired + (require 'dired-x)) @end lisp With @code{dired-x} loaded, @kbd{M-o} toggles omitting in each dired buffer. diff --git a/doc/misc/eieio.texi b/doc/misc/eieio.texi index aceaff051e3..8dd394cb848 100644 --- a/doc/misc/eieio.texi +++ b/doc/misc/eieio.texi @@ -698,6 +698,27 @@ and argument-order conventions are similar to those used for referencing vectors (@pxref{Vectors,,,elisp,GNU Emacs Lisp Reference Manual}). +@defmac oref obj slot +@anchor{oref} +This macro retrieves the value stored in @var{obj} in the named +@var{slot}. Slot names are determined by @code{defclass} which +creates the slot. + +This is a generalized variable that can be used with @code{setf} to +modify the value stored in @var{slot}. @xref{Generalized +Variables,,,elisp,GNU Emacs Lisp Reference Manual}. +@end defmac + +@defmac oref-default class slot +@anchor{oref-default} +This macro returns the value of the class-allocated @var{slot} from +@var{class}. + +This is a generalized variable that can be used with @code{setf} to +modify the value stored in @var{slot}. @xref{Generalized +Variables,,,elisp,GNU Emacs Lisp Reference Manual}. +@end defmac + @defmac oset object slot value This macro sets the value behind @var{slot} to @var{value} in @var{object}. It returns @var{value}. @@ -716,17 +737,6 @@ changed, this can be arranged by simply executing this bit of code: @end example @end defmac -@defmac oref obj slot -@anchor{oref} -Retrieve the value stored in @var{obj} in the slot named by @var{slot}. -Slot is the name of the slot when created by @dfn{defclass}. -@end defmac - -@defmac oref-default class slot -@anchor{oref-default} -Get the value of the class-allocated @var{slot} from @var{class}. -@end defmac - The following accessors are defined by CLOS to reference or modify slot values, and use the previously mentioned set/ref routines. diff --git a/doc/misc/emacs-gnutls.texi b/doc/misc/emacs-gnutls.texi index 7c57cc032c7..bb13ebdf238 100644 --- a/doc/misc/emacs-gnutls.texi +++ b/doc/misc/emacs-gnutls.texi @@ -190,7 +190,7 @@ the connection process. The optional @var{parameters} argument is a list of keywords and values. The only keywords which currently have any effect are -@code{:client-certificate} and @code{:nowait}. +@code{:client-certificate}, @code{:nowait}, and @code{:coding}. Passing @w{@code{:client certificate t}} triggers looking up of client certificates matching @var{host} and @var{service} using the diff --git a/doc/misc/emacs-mime.texi b/doc/misc/emacs-mime.texi index 42a7750b9ac..2f38dcd4956 100644 --- a/doc/misc/emacs-mime.texi +++ b/doc/misc/emacs-mime.texi @@ -917,7 +917,7 @@ Here's an example: @lisp (add-to-list 'gnus-newsgroup-variables 'mm-coding-system-priorities) (setq gnus-parameters - (nconc + (append ;; Some charsets are just examples! '(("^cn\\." ;; Chinese (mm-coding-system-priorities diff --git a/doc/misc/eshell.texi b/doc/misc/eshell.texi index 57f713635f8..c33ca0ea02c 100644 --- a/doc/misc/eshell.texi +++ b/doc/misc/eshell.texi @@ -159,6 +159,9 @@ The following persons have made contributions to Eshell. @itemize @bullet @item +John Wiegley is the original author of Eshell. + +@item Eli Zaretskii made it possible for Eshell to run without requiring asynchronous subprocess support. This is important for MS-DOS, which does not have such support. diff --git a/doc/misc/eudc.texi b/doc/misc/eudc.texi index 701340ed6e2..4ead6032b74 100644 --- a/doc/misc/eudc.texi +++ b/doc/misc/eudc.texi @@ -83,6 +83,8 @@ Currently supported back-ends are: LDAP, Lightweight Directory Access Protocol @item BBDB, Big Brother's Insidious Database +@item +macOS Contacts @end itemize The main features of the EUDC interface are: @@ -107,6 +109,7 @@ Interface to BBDB to let you insert server records into your own BBDB database @menu * LDAP:: What is LDAP ? * BBDB:: What is BBDB ? +* macOS Contacts:: What is macOS Contacts ? @end menu @@ -159,6 +162,21 @@ queries on multiple servers. EUDC also offers a means to insert results from directory queries into your own local BBDB (@pxref{Creating BBDB Records}) + +@node macOS Contacts +@section macOS Contacts + +macOS Contacts is the rolodex-like application that ships with the +macOS operating system@footnote{Apple have changed the names of their +operating system and some applications over time. macOS used to be +called Mac OS X in the past, and the Contacts application was +previously called Address Book.}. + +EUDC considers macOS Contacts as a directory server back end just like +LDAP, though the macOS Contacts application always resides locally on +your machine. + + @node Installation @chapter Installation @@ -185,6 +203,7 @@ email composition buffers (@pxref{Inline Query Expansion}) @menu * LDAP Configuration:: EUDC needs external support for LDAP +* macOS Contacts Configuration:: Enable the macOS Contacts backend @end menu @node LDAP Configuration @@ -379,6 +398,39 @@ The @command{ldapsearch} command is formatted such that it can be copied and pasted into a terminal. Set the @command{ldapsearch} debug level to 5 by appending @code{-d 5} to the command line. + +@node macOS Contacts Configuration +@section macOS Contacts Configuration + +macOS Contacts support is added by means of @file{eudcb-mab.el}, or +@file{eudcb-macos-contacts.el} which are part of Emacs. + +To enable a macOS Contacts backend, first `require' the respective +library to load it, and then set the `eudc-server' to localhost in +your init file: +@lisp +(require 'eudcb-macos-contacts) +(eudc-macos-contacts-set-server "localhost") +@end lisp + +@file{eudcb-macos-contacts.el} uses the public scripting interfaces +offered by the Contacts app via the macOS Open Scripting Architecture +(OSA). To accomplish this, @file{eudcb-macos-contacts.el} uses an +external command line utility named osascript, which is included with +all macOS versions since 10.0 (which was released 2001). +@file{eudcb-macos-contacts.el} is hence recommended for all new +configurations. + +@file{eudcb-mab.el} reverse engineers the format of the database file +used by the macOS Contacts app, and accesses its contents directly. +While this may promise some performance advantages, it comes at the +cost of using an undocumented interface. Hence, users of +@file{eudcb-mab.el} are recommended to double check the compatibility +of @file{eudcb-mab.el} before upgrading to a new version of macOS. +@file{eudcb-mab.el} is retained for backwards compatibility with +existing configurations, and may be removed in a future release. + + @node Usage @chapter Usage diff --git a/doc/misc/eww.texi b/doc/misc/eww.texi index e3191cbe48a..f9901b6fd78 100644 --- a/doc/misc/eww.texi +++ b/doc/misc/eww.texi @@ -135,7 +135,9 @@ HTML-specified colors or not. This sets the @code{shr-use-colors} variable. A URL can be downloaded with @kbd{d} (@code{eww-download}). This will download the link under point if there is one, or else the URL of the current page. The file will be written to the directory specified -in @code{eww-download-directory} (default: @file{~/Downloads/}). +by @code{eww-download-directory} (default: @file{~/Downloads/}, if it +exists; otherwise as specified by the @samp{DOWNLOAD} @acronym{XDG} +directory)). @findex eww-back-url @findex eww-forward-url @@ -283,6 +285,14 @@ contrast. If that is still too low for you, you can customize the variables @code{shr-color-visible-distance-min} and @code{shr-color-visible-luminance-min} to get a better contrast. +@vindex shr-max-width +@vindex shr-width + By default, the max width used when rendering is 120 characters, but +this can be adjusted by changing the @code{shr-max-width} variable. +If a specified width is preferred no matter what the width of the +window is, @code{shr-width} can be set. If both variables are +@code{nil}, the window width will always be used. + @vindex shr-discard-aria-hidden @cindex @code{aria-hidden}, HTML attribute The HTML attribute @code{aria-hidden} is meant to tell screen diff --git a/doc/misc/gnus-coding.texi b/doc/misc/gnus-coding.texi index 55320bf4c32..9a14a95f797 100644 --- a/doc/misc/gnus-coding.texi +++ b/doc/misc/gnus-coding.texi @@ -96,16 +96,6 @@ Read passwords from user, possibly using a password cache. @c As of 2005-10-21... There are no Gnus dependencies in this file. -@item tls.el -TLS/SSL support via wrapper around GnuTLS -@c As of 2005-10-21... -There are no Gnus dependencies in this file. - -@item pgg*.el -Glue for the various PGP implementations. -@c As of 2005-10-21... -There are no Gnus dependencies in these files. - @item sha1.el SHA1 Secure Hash Algorithm. @c As of 2007-08-25... diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index c8ac7f0a7c2..584c54674dd 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -402,6 +402,7 @@ This manual corresponds to Gnus v5.13 @end iftex @menu +* Don't Panic:: Your first 20 minutes with Gnus. * Starting Up:: Finding news can be a pain. * Group Buffer:: Selecting, subscribing and killing groups. * Summary Buffer:: Reading, saving and posting articles. @@ -436,7 +437,7 @@ Starting Gnus * Finding the News:: Choosing a method for getting news. * The Server is Down:: How can I read my mail then? -* Slave Gnusae:: You can have more than one Gnus active at a time. +* Child Gnusae:: You can have more than one Gnus active at a time. * Fetching a Group:: Starting Gnus just to read a group. * New Groups:: What is Gnus supposed to do with new groups? * Changing Servers:: You may want to move from one server to another. @@ -947,6 +948,140 @@ Emacs for Heathens @end detailmenu @end menu +@node Don't Panic +@chapter Don't Panic +@cindex don't panic +@cindex introduction to Gnus + +Welcome, gentle user, to the Gnus newsreader and email client! Gnus +is unlike most clients, in part because of its endless +configurability, in part because of its historical origins. Gnus is +now a fully-featured email client, but it began life as a Usenet-style +newsreader, and its genes are still newsreader genes. Thus it behaves +a little differently than most mail clients. + +The typical assumptions of a newsreader are: + +@enumerate +@item +The server offers a potentially enormous number of newsgroups on a +variety of subjects. The user may only be interested in some of those +groups, and more interested in some than others. +@item +Many groups see a high volume of articles, and the user won't want to +read all of them. Mechanisms are needed for foregrounding interesting +articles, and backgrounding uninteresting articles. +@item +Once a group has been scanned and dealt with by the user, it's +unlikely to be of further interest until new articles come in. +@end enumerate + +These assumptions lead to certain default Gnus behaviors: + +@enumerate +@item +Not all interesting groups are equally interesting, thus groups have +varying degrees of ``subscribedness'', with different behavior +depending on ``how subscribed'' a group is. +@item +There are many commands and tools for scoring and sorting articles, +or otherwise sweeping them under the rug. +@item +Gnus will only show you groups with unread or ticked articles; +groups with no new articles are hidden. +@item +When entering a group, only unread or ticked articles are shown, +all other articles are hidden. +@end enumerate + +If this seems draconian, think of it as Automatic Inbox Zero. This is +the way Gnus works by default. It is possible to make it work more +like an email client (always showing read groups and read articles), +but that takes some effort on the part of the user. + +The brief introduction below should be enough to get you off the +ground. + +@heading The Basics of Servers, Groups, and Articles +@cindex servers +@cindex groups +@cindex articles + +The fundamental building blocks of Gnus are @dfn{servers}, +@dfn{groups}, and @dfn{articles}. Servers can be local or remote. +Each server maintains a list of groups, and those groups contain +articles. Because Gnus presents a unified interface to a wide variety +of servers, the vocabulary doesn't always quite line up (see @ref{FAQ +- Glossary}, for a more complete glossary). Thus a local maildir is +referred to as a ``server'' (@pxref{Finding the News}) the same as a +Usenet or IMAP server is; ``groups'' (@pxref{Group Buffer}) might mean +an NNTP group, IMAP folder, or local mail directory; and an +``article'' (@pxref{Summary Buffer}) might elsewhere be known as a +message or an email. Gnus employs unified terms for all these things. + +Servers fall into two general categories: ``news-like'', meaning that +the articles are part of a public archive and can't be manipulated by +the user; and ``mail-like'', meaning that the articles are owned by +the user, who can freely edit them, move them around, and delete +them. + +For news-like servers, which typically offer hundreds or thousands of +groups, it's important to be able to subscribe to a subset of those +groups. For mail-like servers, the user is generally automatically +subscribed to all groups (though IMAP, for example, also allows +selective subscription). To change group subscription, enter the +Server buffer (with @kbd{^}) and press @kbd{@key{RET}} on the server +in question. From here, Gnus provides commands to change or toggle +your group subscriptions (@pxref{Browse Foreign Server}). + +A Gnus installation is basically just a list of one or more servers, +plus the user's subscribed groups from those servers, plus articles in +those groups. + +Servers can be added and configured in two places: in the user's +gnus.el startup file, using the @code{gnus-select-method} and +@code{gnus-secondary-select-methods} options, or within Gnus itself +using interactive commands in the Server buffer. @xref{Finding +the News}, for details. + + +@heading Fetching Mail + +New mail has to come from somewhere. Some servers, such as NNTP or +IMAP, are themselves responsible for fetching newly-arrived articles. +Others, such as maildir or mbox servers, only store articles and don't +fetch them from anywhere. + +In the latter case, Gnus provides for @code{mail sources}: places +where new mail is fetched from. A mail source might be a local spool, +or a remote POP server, or some other source of incoming articles. +Mail sources are usually configured globally, but can be specified +per-group (@pxref{Mail Sources} for more information). + +@xref{Scanning New Messages}, for details on fetching new mail. + +@heading Viewing Mail + +By default, Gnus's Group buffer only displays groups with unread +articles. It is always possible to display all the groups temporarily +with @kbd{L}, and to configure Gnus to always display some groups +(@pxref{Listing Groups}). + +@xref{Selecting a Group}, for how to enter a group, and @pxref{Summary +Buffer} for what to do once you're there. + +@heading Sending Mail + +New message composition can be initiated from the Group buffer +(@pxref{Misc Group Stuff}). If you're in a Summary buffer, you can +compose replies and forward emails in addition to starting new +messages, see @ref{Summary Mail Commands}, for details. + +For information about what happens once you've started composing a +message, see @ref{Composing Messages}. For information on setting up +@acronym{SMTP} servers in particular, see @ref{Mail Variables, ,Mail +Variables,message,Message manual}. + @node Starting Up @chapter Starting Gnus @cindex starting up @@ -976,7 +1111,7 @@ terminology section (@pxref{Terminology}). @menu * Finding the News:: Choosing a method for getting news. * The Server is Down:: How can I read my mail then? -* Slave Gnusae:: You can have more than one Gnus active at a time. +* Child Gnusae:: You can have more than one Gnus active at a time. * New Groups:: What is Gnus supposed to do with new groups? * Changing Servers:: You may want to move from one server to another. * Startup Files:: Those pesky startup files---@file{.newsrc}. @@ -1090,9 +1225,9 @@ your primary server---instead, it will just activate all groups on level levels.) Also @pxref{Group Levels}. -@node Slave Gnusae -@section Slave Gnusae -@cindex slave +@node Child Gnusae +@section Child Gnusae +@cindex child You might want to run more than one Emacs with more than one Gnus at the same time. If you are using different @file{.newsrc} files (e.g., if you @@ -1103,31 +1238,27 @@ The problem appears when you want to run two Gnusae that use the same @file{.newsrc} file. To work around that problem some, we here at the Think-Tank at the Gnus -Towers have come up with a new concept: @dfn{Masters} and -@dfn{slaves}. (We have applied for a patent on this concept, and have -taken out a copyright on those words. If you wish to use those words in -conjunction with each other, you have to send $1 per usage instance to -me. Usage of the patent (@dfn{Master/Slave Relationships In Computer -Applications}) will be much more expensive, of course.) - -@findex gnus-slave +Towers have come up with a new concept: @dfn{Parents} and +@dfn{children}. + +@findex gnus-child Anyway, you start one Gnus up the normal way with @kbd{M-x gnus} (or -however you do it). Each subsequent slave Gnusae should be started with -@kbd{M-x gnus-slave}. These slaves won't save normal @file{.newsrc} -files, but instead save @dfn{slave files} that contain information only -on what groups have been read in the slave session. When a master Gnus -starts, it will read (and delete) these slave files, incorporating all -information from them. (The slave files will be read in the sequence +however you do it). Each subsequent child Gnusae should be started with +@kbd{M-x gnus-child}. These children won't save normal @file{.newsrc} +files, but instead save @dfn{child files} that contain information only +on what groups have been read in the child session. When a parent Gnus +starts, it will read (and delete) these child files, incorporating all +information from them. (The child files will be read in the sequence they were created, so the latest changes will have precedence.) -Information from the slave files has, of course, precedence over the -information in the normal (i.e., master) @file{.newsrc} file. +Information from the child files has, of course, precedence over the +information in the normal (i.e., parent) @file{.newsrc} file. -If the @file{.newsrc*} files have not been saved in the master when the -slave starts, you may be prompted as to whether to read an auto-save -file. If you answer ``yes'', the unsaved changes to the master will be -incorporated into the slave. If you answer ``no'', the slave may see some -messages as unread that have been read in the master. +If the @file{.newsrc*} files have not been saved in the parent when the +child starts, you may be prompted as to whether to read an auto-save +file. If you answer ``yes'', the unsaved changes to the parent will be +incorporated into the child. If you answer ``no'', the child may see some +messages as unread that have been read in the parent. @@ -1563,12 +1694,6 @@ secondary select methods. @table @code -@item gnus-load-hook -@vindex gnus-load-hook -A hook run while Gnus is being loaded. Note that this hook will -normally be run just once in each Emacs session, no matter how many -times you start Gnus. - @item gnus-before-startup-hook @vindex gnus-before-startup-hook A hook called as the first thing when Gnus is started. @@ -9070,6 +9195,9 @@ when filling. @findex gnus-article-fill-long-lines Fill long lines (@code{gnus-article-fill-long-lines}). +You can give the command a numerical prefix to specify the width to use +when filling. + @item W C @kindex W C @r{(Summary)} @findex gnus-article-capitalize-sentences @@ -27917,7 +28045,7 @@ The revised Gnus @acronym{FAQ} is included in the manual, @acronym{TLS} wrapper shipped with Gnus @acronym{TLS}/@acronym{SSL} is now supported in @acronym{IMAP} and -@acronym{NNTP} via @file{tls.el} and GnuTLS. +@acronym{NNTP} via GnuTLS. @item Improved anti-spam features. @@ -28493,9 +28621,9 @@ entry. The format spec @code{%C} for positioning point has changed to @code{%*}. @item -@code{gnus-slave-unplugged} +@code{gnus-child-unplugged} -A new command which starts Gnus offline in slave mode. +A new command which starts Gnus offline in child mode. @end itemize diff --git a/doc/misc/idlwave.texi b/doc/misc/idlwave.texi index 547b16622fc..5cb6b19181c 100644 --- a/doc/misc/idlwave.texi +++ b/doc/misc/idlwave.texi @@ -1805,8 +1805,8 @@ Structure tag completion is not enabled by default. To enable it, simply add the following to your @file{.emacs}: @lisp - (add-hook 'idlwave-load-hook - (lambda () (require 'idlw-complete-structtag))) +(with-eval-after-load 'idlwave + (require 'idlw-complete-structtag)) @end lisp Once enabled, you'll also be able to access online help on the structure @@ -2360,10 +2360,6 @@ is first called. Normal hook. Executed when a buffer is put into @code{idlwave-mode}. @end defopt -@defopt idlwave-load-hook -Normal hook. Executed when @file{idlwave.el} is loaded. -@end defopt - @node The IDLWAVE Shell @chapter The IDLWAVE Shell @cindex IDLWAVE shell diff --git a/doc/misc/ido.texi b/doc/misc/ido.texi index 74d0bdd29fc..7cc4edd2865 100644 --- a/doc/misc/ido.texi +++ b/doc/misc/ido.texi @@ -590,7 +590,7 @@ Now you can customize @code{completion-ignored-extensions} as well. Go ahead and add all the useless object files, backup files, shared library files and other computing flotsam you don't want Ido to show. -@strong{Note:} Ido will still complete the ignored elements +@strong{Please note:} Ido will still complete the ignored elements if it would otherwise not show any other matches. So if you type out the name of an ignored file, Ido will still let you open it just fine. diff --git a/doc/misc/org.texi b/doc/misc/org.texi index 6f6fcd640d0..495d562f50b 100644 --- a/doc/misc/org.texi +++ b/doc/misc/org.texi @@ -3979,10 +3979,9 @@ key bindings for this are really too long; you might want to bind this also to @kbd{M-n} and @kbd{M-p}. @lisp -(add-hook 'org-load-hook - (lambda () - (define-key org-mode-map "\M-n" 'org-next-link) - (define-key org-mode-map "\M-p" 'org-previous-link))) +(with-eval-after-load 'org + (define-key org-mode-map "\M-n" 'org-next-link) + (define-key org-mode-map "\M-p" 'org-previous-link)) @end lisp @end table diff --git a/doc/misc/reftex.texi b/doc/misc/reftex.texi index 013c5639a1e..0dab5241517 100644 --- a/doc/misc/reftex.texi +++ b/doc/misc/reftex.texi @@ -2896,9 +2896,8 @@ default. If you want to have these key bindings available, set in your Note that this variable has to be set before @RefTeX{} is loaded to have an effect. -@vindex reftex-load-hook -Changing and adding to @RefTeX{}'s key bindings is best done in the hook -@code{reftex-load-hook}. For information on the keymaps +Changing and adding to @RefTeX{}'s key bindings is best done using +@code{with-eval-after-load}. For information on the keymaps which should be used to add keys, see @ref{Keymaps and Hooks}. @node Faces @@ -5320,10 +5319,6 @@ argument. The keymap for @RefTeX{} mode. @end deffn -@deffn {Normal Hook} reftex-load-hook -Normal hook which is being run when loading @file{reftex.el}. -@end deffn - @deffn {Normal Hook} reftex-mode-hook Normal hook which is being run when turning on @RefTeX{} mode. @end deffn diff --git a/doc/misc/sem-user.texi b/doc/misc/sem-user.texi index c02887d104a..d151cee02cc 100644 --- a/doc/misc/sem-user.texi +++ b/doc/misc/sem-user.texi @@ -1068,7 +1068,7 @@ You can integrate @semantic{} with the Speedbar. line to your init file: @example -(add-hook 'speedbar-load-hook (lambda () (require 'semantic/sb))) +(with-eval-after-load 'speedbar (require 'semantic/sb)) @end example @noindent diff --git a/doc/misc/smtpmail.texi b/doc/misc/smtpmail.texi index 99612d5c8fb..f29a5a82e86 100644 --- a/doc/misc/smtpmail.texi +++ b/doc/misc/smtpmail.texi @@ -295,26 +295,11 @@ encrypted connection if the server supports it. Other possible values are: @code{starttls} to insist on STARTTLS; @code{ssl} to use TLS/SSL; and @code{plain} for no encryption. -Use of any form of TLS/SSL requires support in Emacs. You can either -use the built-in support (in Emacs 24.1 and later), or the -@file{starttls.el} Lisp library. The built-in support uses the GnuTLS -@footnote{@url{https://www.gnu.org/software/gnutls/}} library. -If your Emacs has GnuTLS support built-in, the function +Use of any form of TLS/SSL requires support in Emacs. You can use the +built-in support for the GnuTLS +@footnote{@url{https://www.gnu.org/software/gnutls/}} library. If your +Emacs has GnuTLS support built-in, the function @code{gnutls-available-p} is defined and returns non-@code{nil}. -Otherwise, you must use the @file{starttls.el} library (see that file for -more information on customization options, etc.). The Lisp library -requires one of the following external tools to be installed: - -@enumerate -@item -The GnuTLS command line tool @samp{gnutls-cli}, which you can get from -@url{https://www.gnu.org/software/gnutls/}. This is the recommended -tool, mainly because it can verify server certificates. - -@item -The @samp{starttls} external program, which you can get from -@file{starttls-*.tar.gz} from @uref{ftp://ftp.opaopa.org/pub/elisp/}. -@end enumerate @cindex certificates @cindex keys diff --git a/doc/misc/speedbar.texi b/doc/misc/speedbar.texi index 57ad0220103..c9c3daf963b 100644 --- a/doc/misc/speedbar.texi +++ b/doc/misc/speedbar.texi @@ -828,9 +828,6 @@ Hooks run when speedbar visits a file in the selected frame. @cindex @code{speedbar-visiting-tag-hook} @item speedbar-visiting-tag-hook Hooks run when speedbar visits a tag in the selected frame. -@cindex @code{speedbar-load-hook} -@item speedbar-load-hook -Hooks run when speedbar is loaded. @cindex @code{speedbar-reconfigure-keymaps-hook} @item speedbar-reconfigure-keymaps-hook Hooks run when the keymaps are regenerated. Keymaps are reconfigured @@ -913,12 +910,11 @@ bindings: This function creates a special keymap for use in speedbar. @item -Call your install function, or assign it to a hook like this: +Call your install function, like this: @smallexample -(if (featurep 'speedbar) - (@var{name}-install-speedbar-variables) - (add-hook 'speedbar-load-hook '@var{name}-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (@var{name}-install-speedbar-variables)) @end smallexample @item diff --git a/doc/misc/texinfo.tex b/doc/misc/texinfo.tex index 6d9d7113f77..d3136db38aa 100644 --- a/doc/misc/texinfo.tex +++ b/doc/misc/texinfo.tex @@ -3,9 +3,9 @@ % Load plain if necessary, i.e., if running under initex. \expandafter\ifx\csname fmtname\endcsname\relax\input plain\fi % -\def\texinfoversion{2019-09-24.13} +\def\texinfoversion{2020-05-22.11} % -% Copyright 1985--1986, 1988, 1990--2020 Free Software Foundation, Inc. +% Copyright 1985, 1986, 1988, 1990-2020 Free Software Foundation, Inc. % % This texinfo.tex file is free software: you can redistribute it and/or % modify it under the terms of the GNU General Public License as @@ -33,7 +33,7 @@ % The texinfo.tex in any given distribution could well be out % of date, so if that's what you're using, please check. % -% Send bug reports to bug-texinfo@gnu.org. Please include including a +% Send bug reports to bug-texinfo@gnu.org. Please include a % complete document in each bug report with which we can reproduce the % problem. Patches are, of course, greatly appreciated. % @@ -349,36 +349,21 @@ \ifodd\pageno \advance\hoffset by \bindingoffset \else \advance\hoffset by -\bindingoffset\fi % + \checkchapterpage + % % Retrieve the information for the headings from the marks in the page, % and call Plain TeX's \makeheadline and \makefootline, which use the % values in \headline and \footline. % - % This is used to check if we are on the first page of a chapter. - \ifcase1\the\savedtopmark\fi - \let\prevchaptername\thischaptername - \ifcase0\firstmark\fi - \let\curchaptername\thischaptername - % - \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi - % - \ifx\curchaptername\prevchaptername - \let\thischapterheading\thischapter - \else - % \thischapterheading is the same as \thischapter except it is blank - % for the first page of a chapter. This is to prevent the chapter name - % being shown twice. - \def\thischapterheading{}% - \fi - % % Common context changes for both heading and footing. % Do this outside of the \shipout so @code etc. will be expanded in % the headline as they should be, not taken literally (outputting ''code). - \def\commmonheadfootline{\let\hsize=\txipagewidth \texinfochars} - % - \global\setbox\headlinebox = \vbox{\commmonheadfootline \makeheadline}% + \def\commonheadfootline{\let\hsize=\txipagewidth \texinfochars} % + \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi + \global\setbox\headlinebox = \vbox{\commonheadfootline \makeheadline}% \ifodd\pageno \getoddfootingmarks \else \getevenfootingmarks \fi - \global\setbox\footlinebox = \vbox{\commmonheadfootline \makefootline}% + \global\setbox\footlinebox = \vbox{\commonheadfootline \makefootline}% % {% % Set context for writing to auxiliary files like index files. @@ -423,6 +408,22 @@ \ifr@ggedbottom \kern-\dimen@ \vfil \fi} } +% Check if we are on the first page of a chapter. Used for printing headings. +\newif\ifchapterpage +\def\checkchapterpage{% + % Get the chapter that was current at the end of the last page + \ifcase1\the\savedtopmark\fi + \let\prevchaptername\thischaptername + % + \ifodd\pageno \getoddheadingmarks \else \getevenheadingmarks \fi + \let\curchaptername\thischaptername + % + \ifx\curchaptername\prevchaptername + \chapterpagefalse + \else + \chapterpagetrue + \fi +} % Argument parsing @@ -1010,7 +1011,7 @@ where each line of input produces a line of output.} \let\setfilename=\comment % @bye. -\outer\def\bye{\pagealignmacro\tracingstats=1\ptexend} +\outer\def\bye{\chappager\pagelabels\tracingstats=1\ptexend} \message{pdf,} @@ -1137,6 +1138,45 @@ where each line of input produces a line of output.} \fi +% Output page labels information. +% See PDF reference v.1.7 p.594, section 8.3.1. +\ifpdf +\def\pagelabels{% + \def\title{0 << /P (T-) /S /D >>}% + \edef\roman{\the\romancount << /S /r >>}% + \edef\arabic{\the\arabiccount << /S /D >>}% + % + % Page label ranges must be increasing. Remove any duplicates. + % (There is a slight chance of this being wrong if e.g. there is + % a @contents but no @titlepage, etc.) + % + \ifnum\romancount=0 \def\roman{}\fi + \ifnum\arabiccount=0 \def\title{}% + \else + \ifnum\romancount=\arabiccount \def\roman{}\fi + \fi + % + \ifnum\romancount<\arabiccount + \pdfcatalog{/PageLabels << /Nums [\title \roman \arabic ] >> }\relax + \else + \pdfcatalog{/PageLabels << /Nums [\title \arabic \roman ] >> }\relax + \fi +} +\else + \let\pagelabels\relax +\fi + +\newcount\pagecount \pagecount=0 +\newcount\romancount \romancount=0 +\newcount\arabiccount \arabiccount=0 +\ifpdf + \let\ptxadvancepageno\advancepageno + \def\advancepageno{% + \ptxadvancepageno\global\advance\pagecount by 1 + } +\fi + + % PDF uses PostScript string constants for the names of xref targets, % for display in the outlines, and in other places. Thus, we have to % double any backslashes. Otherwise, a name like "\node" will be @@ -1427,7 +1467,13 @@ output) for that.)} % subentries, which we calculated on our first read of the .toc above. % % We use the node names as the destinations. + % + % Currently we prefix the section name with the section number + % for chapter and appendix headings only in order to avoid too much + % horizontal space being required in the PDF viewer. \def\numchapentry##1##2##3##4{% + \dopdfoutline{##2 ##1}{count-\expnumber{chap##2}}{##3}{##4}}% + \def\unnchapentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{chap##2}}{##3}{##4}}% \def\numsecentry##1##2##3##4{% \dopdfoutline{##1}{count-\expnumber{sec##2}}{##3}{##4}}% @@ -1669,9 +1715,13 @@ output) for that.)} % Therefore, we read toc only once. % % We use node names as destinations. + % + % Currently we prefix the section name with the section number + % for chapter and appendix headings only in order to avoid too much + % horizontal space being required in the PDF viewer. \def\partentry##1##2##3##4{}% ignore parts in the outlines \def\numchapentry##1##2##3##4{% - \dopdfoutline{##1}{1}{##3}{##4}}% + \dopdfoutline{##2 ##1}{1}{##3}{##4}}% \def\numsecentry##1##2##3##4{% \dopdfoutline{##1}{2}{##3}{##4}}% \def\numsubsecentry##1##2##3##4{% @@ -1683,7 +1733,8 @@ output) for that.)} \let\appsecentry\numsecentry% \let\appsubsecentry\numsubsecentry% \let\appsubsubsecentry\numsubsubsecentry% - \let\unnchapentry\numchapentry% + \def\unnchapentry##1##2##3##4{% + \dopdfoutline{##1}{1}{##3}{##4}}% \let\unnsecentry\numsecentry% \let\unnsubsecentry\numsubsecentry% \let\unnsubsubsecentry\numsubsubsecentry% @@ -2496,7 +2547,7 @@ end \def\it{\fam=\itfam \setfontstyle{it}} \def\sl{\fam=\slfam \setfontstyle{sl}} \def\bf{\fam=\bffam \setfontstyle{bf}}\def\bfstylename{bf} -\def\tt{\fam=\ttfam \setfontstyle{tt}} +\def\tt{\fam=\ttfam \setfontstyle{tt}}\def\ttstylename{tt} % Texinfo sort of supports the sans serif font style, which plain TeX does not. % So we set up a \sf. @@ -3101,15 +3152,15 @@ end % Allow a ragged right output to aid breaking long URL's. There can % be a break at the \allowbreak with no extra glue (if the existing stretch in -% the line is sufficent), a break at the \penalty100 with extra glue added +% the line is sufficient), a break at the \penalty100 with extra glue added % at the end of the line, or no break at all here. % Changing the value of the penalty and/or the amount of stretch affects how -% preferrable one choice is over the other. +% preferable one choice is over the other. \def\urefallowbreak{% \allowbreak - \hskip 0pt plus 4 em\relax - \penalty100 - \hskip 0pt plus -4 em\relax + \hskip 0pt plus 2 em\relax + \penalty300 + \hskip 0pt plus -2 em\relax } \urefbreakstyle after @@ -3509,7 +3560,7 @@ end % @pounds{} is a sterling sign, which Knuth put in the CM italic font. % -\def\pounds{{\it\$}} +\def\pounds{\ifmonospace{\ecfont\char"BF}\else{\it\$}\fi} % @euro{} comes from a separate font, depending on the current style. % We use the free feym* fonts from the eurosym package by Henrik @@ -3658,11 +3709,19 @@ end \fi % Quotes. -\chardef\quotedblleft="5C -\chardef\quotedblright=`\" \chardef\quoteleft=`\` \chardef\quoteright=`\' +% only change font for tt for correct kerning and to avoid using +% \ecfont unless necessary. +\def\quotedblleft{% + \ifmonospace{\ecfont\char"10}\else{\char"5C}\fi +} + +\def\quotedblright{% + \ifmonospace{\ecfont\char"11}\else{\char`\"}\fi +} + \message{page headings,} @@ -3784,12 +3843,19 @@ end \newtoks\evenheadline % headline on even pages \newtoks\oddheadline % headline on odd pages +\newtoks\evenchapheadline% headline on even pages with a new chapter +\newtoks\oddchapheadline % headline on odd pages with a new chapter \newtoks\evenfootline % footline on even pages \newtoks\oddfootline % footline on odd pages % Now make \makeheadline and \makefootline in Plain TeX use those variables -\headline={{\textfonts\rm \ifodd\pageno \the\oddheadline - \else \the\evenheadline \fi}} +\headline={{\textfonts\rm + \ifchapterpage + \ifodd\pageno\the\oddchapheadline\else\the\evenchapheadline\fi + \else + \ifodd\pageno\the\oddheadline\else\the\evenheadline\fi + \fi}} + \footline={{\textfonts\rm \ifodd\pageno \the\oddfootline \else \the\evenfootline \fi}\HEADINGShook} \let\HEADINGShook=\relax @@ -3805,12 +3871,14 @@ end \def\evenheading{\parsearg\evenheadingxxx} \def\evenheadingxxx #1{\evenheadingyyy #1\|\|\|\|\finish} \def\evenheadingyyy #1\|#2\|#3\|#4\finish{% -\global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + \global\evenheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}} + \global\evenchapheadline=\evenheadline} \def\oddheading{\parsearg\oddheadingxxx} \def\oddheadingxxx #1{\oddheadingyyy #1\|\|\|\|\finish} \def\oddheadingyyy #1\|#2\|#3\|#4\finish{% -\global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}} + \global\oddheadline={\rlap{\centerline{#2}}\line{#1\hfil#3}}% + \global\oddchapheadline=\oddheadline} \parseargdef\everyheading{\oddheadingxxx{#1}\evenheadingxxx{#1}}% @@ -3877,37 +3945,34 @@ end \parseargdef\headings{\csname HEADINGS#1\endcsname} \def\headingsoff{% non-global headings elimination - \evenheadline={\hfil}\evenfootline={\hfil}% - \oddheadline={\hfil}\oddfootline={\hfil}% + \evenheadline={\hfil}\evenfootline={\hfil}\evenchapheadline={\hfil}% + \oddheadline={\hfil}\oddfootline={\hfil}\oddchapheadline={\hfil}% } \def\HEADINGSoff{{\globaldefs=1 \headingsoff}} % global setting \HEADINGSoff % it's the default % When we turn headings on, set the page number to 1. +\def\pageone{ + \global\pageno=1 + \global\arabiccount = \pagecount +} + % For double-sided printing, put current file name in lower left corner, % chapter name on inside top of right hand pages, document % title on inside top of left hand pages, and page numbers on outside top % edge of all pages. \def\HEADINGSdouble{% -\global\pageno=1 -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\folio\hfil\thistitle}} -\global\oddheadline={\line{\thischapterheading\hfil\folio}} -\global\let\contentsalignmacro = \chapoddpage +\pageone +\HEADINGSdoublex } \let\contentsalignmacro = \chappager % For single-sided printing, chapter title goes across top left of page, % page number on top right. \def\HEADINGSsingle{% -\global\pageno=1 -\global\evenfootline={\hfil} -\global\oddfootline={\hfil} -\global\evenheadline={\line{\thischapterheading\hfil\folio}} -\global\oddheadline={\line{\thischapterheading\hfil\folio}} -\global\let\contentsalignmacro = \chappager +\pageone +\HEADINGSsinglex } \def\HEADINGSon{\HEADINGSdouble} @@ -3917,7 +3982,9 @@ end \global\evenfootline={\hfil} \global\oddfootline={\hfil} \global\evenheadline={\line{\folio\hfil\thistitle}} -\global\oddheadline={\line{\thischapterheading\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +\global\evenchapheadline={\line{\folio\hfil}} +\global\oddchapheadline={\line{\hfil\folio}} \global\let\contentsalignmacro = \chapoddpage } @@ -3925,8 +3992,22 @@ end \def\HEADINGSsinglex{% \global\evenfootline={\hfil} \global\oddfootline={\hfil} -\global\evenheadline={\line{\thischapterheading\hfil\folio}} -\global\oddheadline={\line{\thischapterheading\hfil\folio}} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +\global\evenchapheadline={\line{\hfil\folio}} +\global\oddchapheadline={\line{\hfil\folio}} +\global\let\contentsalignmacro = \chappager +} + +% for @setchapternewpage off +\def\HEADINGSsinglechapoff{% +\pageone +\global\evenfootline={\hfil} +\global\oddfootline={\hfil} +\global\evenheadline={\line{\thischapter\hfil\folio}} +\global\oddheadline={\line{\thischapter\hfil\folio}} +\global\evenchapheadline=\evenheadline +\global\oddchapheadline=\oddheadline \global\let\contentsalignmacro = \chappager } @@ -5117,64 +5198,66 @@ end \let\lbracechar\{% \let\rbracechar\}% % + % + \let\do\indexnofontsdef + % % Non-English letters. - \def\AA{AA}% - \def\AE{AE}% - \def\DH{DZZ}% - \def\L{L}% - \def\OE{OE}% - \def\O{O}% - \def\TH{TH}% - \def\aa{aa}% - \def\ae{ae}% - \def\dh{dzz}% - \def\exclamdown{!}% - \def\l{l}% - \def\oe{oe}% - \def\ordf{a}% - \def\ordm{o}% - \def\o{o}% - \def\questiondown{?}% - \def\ss{ss}% - \def\th{th}% - % - \def\LaTeX{LaTeX}% - \def\TeX{TeX}% - % - % Assorted special characters. \defglyph gives the control sequence a - % definition that removes the {} that follows its use. - \defglyph\atchar{@}% - \defglyph\arrow{->}% - \defglyph\bullet{bullet}% - \defglyph\comma{,}% - \defglyph\copyright{copyright}% - \defglyph\dots{...}% - \defglyph\enddots{...}% - \defglyph\equiv{==}% - \defglyph\error{error}% - \defglyph\euro{euro}% - \defglyph\expansion{==>}% - \defglyph\geq{>=}% - \defglyph\guillemetleft{<<}% - \defglyph\guillemetright{>>}% - \defglyph\guilsinglleft{<}% - \defglyph\guilsinglright{>}% - \defglyph\leq{<=}% - \defglyph\lbracechar{\{}% - \defglyph\minus{-}% - \defglyph\point{.}% - \defglyph\pounds{pounds}% - \defglyph\print{-|}% - \defglyph\quotedblbase{"}% - \defglyph\quotedblleft{"}% - \defglyph\quotedblright{"}% - \defglyph\quoteleft{`}% - \defglyph\quoteright{'}% - \defglyph\quotesinglbase{,}% - \defglyph\rbracechar{\}}% - \defglyph\registeredsymbol{R}% - \defglyph\result{=>}% - \defglyph\textdegree{o}% + \do\AA{AA}% + \do\AE{AE}% + \do\DH{DZZ}% + \do\L{L}% + \do\OE{OE}% + \do\O{O}% + \do\TH{TH}% + \do\aa{aa}% + \do\ae{ae}% + \do\dh{dzz}% + \do\exclamdown{!}% + \do\l{l}% + \do\oe{oe}% + \do\ordf{a}% + \do\ordm{o}% + \do\o{o}% + \do\questiondown{?}% + \do\ss{ss}% + \do\th{th}% + % + \do\LaTeX{LaTeX}% + \do\TeX{TeX}% + % + % Assorted special characters. + \do\atchar{@}% + \do\arrow{->}% + \do\bullet{bullet}% + \do\comma{,}% + \do\copyright{copyright}% + \do\dots{...}% + \do\enddots{...}% + \do\equiv{==}% + \do\error{error}% + \do\euro{euro}% + \do\expansion{==>}% + \do\geq{>=}% + \do\guillemetleft{<<}% + \do\guillemetright{>>}% + \do\guilsinglleft{<}% + \do\guilsinglright{>}% + \do\leq{<=}% + \do\lbracechar{\{}% + \do\minus{-}% + \do\point{.}% + \do\pounds{pounds}% + \do\print{-|}% + \do\quotedblbase{"}% + \do\quotedblleft{"}% + \do\quotedblright{"}% + \do\quoteleft{`}% + \do\quoteright{'}% + \do\quotesinglbase{,}% + \do\rbracechar{\}}% + \do\registeredsymbol{R}% + \do\result{=>}% + \do\textdegree{o}% % % We need to get rid of all macros, leaving only the arguments (if present). % Of course this is not nearly correct, but it is the best we can do for now. @@ -5189,7 +5272,10 @@ end \macrolist \let\value\indexnofontsvalue } -\def\defglyph#1#2{\def#1##1{#2}} % see above + +% Give the control sequence a definition that removes the {} that follows +% its use, e.g. @AA{} -> AA +\def\indexnofontsdef#1#2{\def#1##1{#2}}% @@ -6401,18 +6487,16 @@ might help (with 'rm \jobname.?? \jobname.??s')% \def\CHAPPAGoff{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chapbreak -\global\let\pagealignmacro=\chappager} +\global\def\HEADINGSon{\HEADINGSsinglechapoff}} \def\CHAPPAGon{% \global\let\contentsalignmacro = \chappager \global\let\pchapsepmacro=\chappager -\global\let\pagealignmacro=\chappager \global\def\HEADINGSon{\HEADINGSsingle}} \def\CHAPPAGodd{% \global\let\contentsalignmacro = \chapoddpage \global\let\pchapsepmacro=\chapoddpage -\global\let\pagealignmacro=\chapoddpage \global\def\HEADINGSon{\HEADINGSdouble}} \CHAPPAGon @@ -6777,9 +6861,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% % \def\startcontents#1{% % If @setchapternewpage on, and @headings double, the contents should - % start on an odd page, unlike chapters. Thus, we maintain - % \contentsalignmacro in parallel with \pagealignmacro. - % From: Torbjorn Granlund <tege@matematik.su.se> + % start on an odd page, unlike chapters. \contentsalignmacro \immediate\closeout\tocfile % @@ -6794,6 +6876,9 @@ might help (with 'rm \jobname.?? \jobname.??s')% % % Roman numerals for page numbers. \ifnum \pageno>0 \global\pageno = \lastnegativepageno \fi + \def\thistitle{}% no title in double-sided headings + % Record where the Roman numerals started. + \ifnum\romancount=0 \global\romancount=\pagecount \fi } % redefined for the two-volume lispref. We always output on @@ -6816,8 +6901,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% \fi \closein 1 \endgroup - \lastnegativepageno = \pageno - \global\pageno = \savepageno + \contentsendroman } % And just the chapters. @@ -6852,10 +6936,20 @@ might help (with 'rm \jobname.?? \jobname.??s')% \vfill \eject \contentsalignmacro % in case @setchapternewpage odd is in effect \endgroup + \contentsendroman +} +\let\shortcontents = \summarycontents + +% Get ready to use Arabic numerals again +\def\contentsendroman{% \lastnegativepageno = \pageno \global\pageno = \savepageno + % + % If \romancount > \arabiccount, the contents are at the end of the + % document. Otherwise, advance where the Arabic numerals start for + % the page numbers. + \ifnum\romancount>\arabiccount\else\global\arabiccount=\pagecount\fi } -\let\shortcontents = \summarycontents % Typeset the label for a chapter or appendix for the short contents. % The arg is, e.g., `A' for an appendix, or `3' for a chapter. @@ -7444,13 +7538,9 @@ might help (with 'rm \jobname.?? \jobname.??s')% \newdimen\tabw \setbox0=\hbox{\tt\space} \tabw=8\wd0 % tab amount % % We typeset each line of the verbatim in an \hbox, so we can handle -% tabs. The \global is in case the verbatim line starts with an accent, -% or some other command that starts with a begin-group. Otherwise, the -% entire \verbbox would disappear at the corresponding end-group, before -% it is typeset. Meanwhile, we can't have nested verbatim commands -% (can we?), so the \global won't be overwriting itself. +% tabs. \newbox\verbbox -\def\starttabbox{\global\setbox\verbbox=\hbox\bgroup} +\def\starttabbox{\setbox\verbbox=\hbox\bgroup} % \begingroup \catcode`\^^I=\active @@ -7461,7 +7551,8 @@ might help (with 'rm \jobname.?? \jobname.??s')% \divide\dimen\verbbox by\tabw \multiply\dimen\verbbox by\tabw % compute previous multiple of \tabw \advance\dimen\verbbox by\tabw % advance to next multiple of \tabw - \wd\verbbox=\dimen\verbbox \box\verbbox \starttabbox + \wd\verbbox=\dimen\verbbox + \leavevmode\box\verbbox \starttabbox }% } \endgroup @@ -7471,9 +7562,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% \let\nonarrowing = t% \nonfillstart \tt % easiest (and conventionally used) font for verbatim - % The \leavevmode here is for blank lines. Otherwise, we would - % never \starttabbox and the \egroup would end verbatim mode. - \def\par{\leavevmode\egroup\box\verbbox\endgraf}% + \def\par{\egroup\box\verbbox\endgraf\starttabbox}% \tabexpand \setupmarkupstyle{verbatim}% % Respect line breaks, @@ -7481,7 +7570,6 @@ might help (with 'rm \jobname.?? \jobname.??s')% % make each space count. % Must do in this order: \obeylines \uncatcodespecials \sepspaces - \everypar{\starttabbox}% } % Do the @verb magic: verbatim text is quoted by unique @@ -7516,9 +7604,12 @@ might help (with 'rm \jobname.?? \jobname.??s')% % ignore everything up to the first ^^M, that's the newline at the end % of the @verbatim input line itself. Otherwise we get an extra blank % line in the output. - \xdef\doverbatim#1^^M#2@end verbatim{#2\noexpand\end\gobble verbatim}% + \xdef\doverbatim#1^^M#2@end verbatim{% + \starttabbox#2\egroup\noexpand\end\gobble verbatim}% % We really want {...\end verbatim} in the body of the macro, but % without the active space; thus we have to use \xdef and \gobble. + % The \egroup ends the \verbbox started at the end of the last line in + % the block. \endgroup % \envdef\verbatim{% @@ -7540,7 +7631,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% \wlog{texinfo.tex: doing @verbatiminclude of #1^^J}% \edef\tmp{\noexpand\input #1 } \expandafter - }\tmp + }\expandafter\starttabbox\tmp\egroup \afterenvbreak }% } @@ -7690,7 +7781,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% % If SUBTOPIC is present, precede it with a space, and call \doind. % (At some time during the 20th century, this made a two-level entry in an % index such as the operation index. Nobody seemed to notice the change in -% behavior though.) +% behaviour though.) \def\dosubind#1#2#3{% \def\thirdarg{#3}% \ifx\thirdarg\empty @@ -8955,17 +9046,11 @@ might help (with 'rm \jobname.?? \jobname.??s')% \else % Reference within this manual. % - % _ (for example) has to be the character _ for the purposes of the - % control sequence corresponding to the node, but it has to expand - % into the usual \leavevmode...\vrule stuff for purposes of - % printing. So we \turnoffactive for the \refx-snt, back on for the - % printing, back off for the \refx-pg. - {\turnoffactive - % Only output a following space if the -snt ref is nonempty; for - % @unnumbered and @anchor, it won't be. - \setbox2 = \hbox{\ignorespaces \refx{#1-snt}{}}% - \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi - }% + % Only output a following space if the -snt ref is nonempty; for + % @unnumbered and @anchor, it won't be. + \setbox2 = \hbox{\ignorespaces \refx{#1-snt}{}}% + \ifdim \wd2 > 0pt \refx{#1-snt}\space\fi + % % output the `[mynode]' via the macro below so it can be overridden. \xrefprintnodename\printedrefname % @@ -9055,7 +9140,7 @@ might help (with 'rm \jobname.?? \jobname.??s')% \requireauxfile {% \indexnofonts - \otherbackslash + \turnoffactive \def\value##1{##1}% \expandafter\global\expandafter\let\expandafter\thisrefX \csname XR#1\endcsname @@ -10712,6 +10797,8 @@ directory should work if nowhere else does.} \DeclareUnicodeCharacter{0233}{\=y}% \DeclareUnicodeCharacter{0237}{\dotless{j}}% % + \DeclareUnicodeCharacter{02BC}{'}% + % \DeclareUnicodeCharacter{02DB}{\ogonek{ }}% % % Greek letters upper case diff --git a/doc/misc/tramp.texi b/doc/misc/tramp.texi index c68b9aad528..b4195111d4a 100644 --- a/doc/misc/tramp.texi +++ b/doc/misc/tramp.texi @@ -46,7 +46,7 @@ copy and modify this GNU manual.'' @node Top, Overview, (dir), (dir) @top @value{tramp} @value{trampver} User Manual -This file documents @value{tramp} @value{trampver}, a remote file +This file documents @w{@value{tramp} @value{trampver}}, a remote file editing package for Emacs. @value{tramp} stands for ``Transparent Remote (file) Access, Multiple @@ -59,7 +59,7 @@ local and the remote host, whereas @value{tramp} uses a combination of @command{ssh}/@command{scp}. You can find the latest version of this document on the web at -@uref{https://www.gnu.org/software/tramp/}. +@uref{@value{trampurl}}. @ifhtml The latest release of @value{tramp} is available for @@ -141,6 +141,7 @@ Configuring @value{tramp} for use * Remote shell setup:: Remote shell setup hints. * Android shell setup:: Android shell setup hints. * Auto-save and Backup:: Auto-save and Backup. +* Keeping files encrypted:: Protect remote files by encryption. * Windows setup hints:: Issues with Cygwin ssh. Using @value{tramp} @@ -312,21 +313,21 @@ behind the scenes when you open a file with @value{tramp}. @cindex GNU ELPA @vindex tramp-version -@value{tramp} is included as part of Emacs (since Emacs 22.1). +@value{tramp} is included as part of Emacs (since @w{Emacs 22.1}). @value{tramp} is also freely packaged for download on the Internet at @uref{https://ftp.gnu.org/gnu/tramp/}. The version number of @value{tramp} can be obtained by the variable @code{tramp-version}. For released @value{tramp} versions, this is a three-number string -like ``2.4.2''. +like ``2.4.3''. A @value{tramp} release, which is packaged with Emacs, could differ slightly from the corresponding standalone release. This is because it isn't always possible to synchronize release dates between Emacs and @value{tramp}. Such version numbers have the Emacs version number -as suffix, like ``2.3.5.26.3''. This means @value{tramp} 2.3.5 as -integrated in Emacs 26.3. A complete list of @value{tramp} versions -packaged with Emacs can be retrieved by +as suffix, like ``2.4.3.27.1''. This means @w{@value{tramp} 2.4.3} as +integrated in @w{Emacs 27.1}. A complete list of @value{tramp} +versions packaged with Emacs can be retrieved by @vindex customize-package-emacs-version-alist @lisp @@ -337,12 +338,12 @@ packaged with Emacs can be retrieved by ELPA} package. Besides the standalone releases, further minor version of @value{tramp} will appear on GNU ELPA, until the next @value{tramp} release appears. These minor versions have a four-number string, like -``2.4.2.1''. +``2.4.3.1''. @value{tramp} development versions are available on Git servers. Development versions contain new and incomplete features. The development version of @value{tramp} is always the version number of -the next release, plus the suffix ``-pre'', like ``2.4.3-pre''. +the next release, plus the suffix ``-pre'', like ``2.4.4-pre''. One way to obtain @value{tramp} from Git server is to visit the Savannah project page at the following URL and then clicking on the @@ -557,13 +558,16 @@ of the local file name is the share exported by the remote host, @cindex method @option{davs} @cindex @option{dav} method @cindex @option{davs} method +@cindex method @option{media} +@cindex @option{media} method On systems, which have installed @acronym{GVFS, the GNOME Virtual File System}, its offered methods could be used by @value{tramp}. Examples are @file{@trampfn{sftp,user@@host,/path/to/file}}, @file{@trampfn{afp,user@@host,/path/to/file}} (accessing Apple's AFP -file system), @file{@trampfn{dav,user@@host,/path/to/file}} and -@file{@trampfn{davs,user@@host,/path/to/file}} (for WebDAV shares). +file system), @file{@trampfn{dav,user@@host,/path/to/file}}, +@file{@trampfn{davs,user@@host,/path/to/file}} (for WebDAV shares) and +@file{@trampfn{media,device,/path/to/file}} (for media devices). @anchor{Quick Start Guide: GNOME Online Accounts based methods} @@ -664,6 +668,7 @@ might be used in your init file: * Remote shell setup:: Remote shell setup hints. * Android shell setup:: Android shell setup hints. * Auto-save and Backup:: Auto-save and Backup. +* Keeping files encrypted:: Protect remote files by encryption. * Windows setup hints:: Issues with Cygwin ssh. @end menu @@ -1126,7 +1131,8 @@ Emacs. @value{tramp} does not require a host name part of the remote file name when a single Android device is connected to @command{adb}. @value{tramp} instead uses @file{@trampfn{adb,,}} as the default name. -@command{adb devices} shows available host names. +@command{adb devices}, run in a shell outside Emacs, shows available +host names. @option{adb} method normally does not need user name to authenticate on the Android device because it runs under the @command{adbd} @@ -1179,9 +1185,6 @@ for accessing the system storage, you shall prefer this. @ref{GVFS-based methods} for example, methods @option{gdrive} and @option{nextcloud}. -@strong{Note}: The @option{rclone} method is experimental, don't use -it in production systems! - @end table @@ -1227,6 +1230,7 @@ supported by these methods. See method @option{nextcloud} for handling them. @item @option{gdrive} +@cindex @acronym{GNOME} Online Accounts @cindex method @option{gdrive} @cindex @option{gdrive} method @cindex google drive @@ -1242,8 +1246,26 @@ Since Google Drive uses cryptic blob file names internally, could produce unexpected behavior in case two files in the same directory have the same @code{display-name}, such a situation must be avoided. +@item @option{media} +@cindex method @option{media} +@cindex @option{media} method +@cindex media + +Media devices, like cell phones, tablets, cameras, can be accessed via +the @option{media} method. Just the device name is needed in order to +specify the host in the file name. However, the device must already +be connected via USB, before accessing it. Possible device names are +visible via host name completion, @ref{File name completion}. + +Depending on the device type, the access could be read-only. Some +devices are accessible under different names in parallel, offering +different parts of their file system. + +@value{tramp} does not require a host name as part of the remote file +name when a single media device is connected. @value{tramp} instead +uses @file{@trampfn{media,,}} as the default name. + @item @option{nextcloud} -@cindex @acronym{GNOME} Online Accounts @cindex method @option{nextcloud} @cindex @option{nextcloud} method @cindex nextcloud @@ -1267,11 +1289,11 @@ that for security reasons refuse @command{ssh} connections. @defopt tramp-gvfs-methods This user option is a list of external methods for @acronym{GVFS}@. By default, this list includes @option{afp}, @option{dav}, -@option{davs}, @option{gdrive}, @option{nextcloud} and @option{sftp}. -Other methods to include are @option{ftp}, @option{http}, -@option{https} and @option{smb}. These methods are not intended to be -used directly as @acronym{GVFS}-based method. Instead, they are added -here for the benefit of @ref{Archive file names}. +@option{davs}, @option{gdrive}, @option{media}, @option{nextcloud} and +@option{sftp}. Other methods to include are @option{ftp}, +@option{http}, @option{https} and @option{smb}. These methods are not +intended to be used directly as @acronym{GVFS}-based method. Instead, +they are added here for the benefit of @ref{Archive file names}. If you want to use @acronym{GVFS}-based @option{ftp} or @option{smb} methods, you must add them to @code{tramp-gvfs-methods}, and you must @@ -1642,7 +1664,7 @@ suitable settings. Refer to the Lisp documentation of that variable, accessible with @kbd{C-h v tramp-methods @key{RET}}. In the ELPA archives, there are several examples of such extensions. -They can be installed with Emacs' Package Manager. This includes +They can be installed with Emacs's Package Manager. This includes @table @samp @c @item anything-tramp @@ -1708,6 +1730,7 @@ Convenience method to access vagrant boxes. It is often used in multi-hop file names like @file{@value{prefix}vagrant@value{postfixhop}box|sudo@value{postfixhop}box@value{postfix}/path/to/file}, where @samp{box} is the name of the vagrant box. + @end table @@ -2102,8 +2125,8 @@ preserves the path value, which can be used to update shell supports the login argument @samp{-l}. @end defopt -Starting with Emacs 26, @code{tramp-remote-path} can be set per host -via connection-local +Starting with @w{Emacs 26}, @code{tramp-remote-path} can be set per +host via connection-local @ifinfo variables, @xref{Connection Variables, , , emacs}. @end ifinfo @@ -2299,7 +2322,7 @@ string of that environment variable looks always like @example @group echo $INSIDE_EMACS -@result{} 26.2,tramp:2.3.4 +@result{} 27.1,tramp:2.4.3 @end group @end example @@ -2457,7 +2480,7 @@ where @samp{192.168.0.1} is the remote host IP address Android devices provide a restricted shell access through an USB connection. The local host must have the @command{adb} program installed. Usually, it is sufficient to open the file -@file{@trampfn{adb,,/}}. Then you can navigate in the filesystem via +@file{@trampfn{adb,,/}}. Then you can navigate in the file system via @code{dired}. Alternatively, applications such as @code{Termux} or @code{SSHDroid} @@ -2632,6 +2655,117 @@ auto-saved files to the same directory as the original file. Alternatively, set the user option @code{tramp-auto-save-directory} to direct all auto saves to that location. + +@node Keeping files encrypted +@section Protect remote files by encryption +@cindex Encrypt remote directories + +@strong{Note}: File encryption in @value{tramp} is experimental, don't +use it in production systems! + +Sometimes, it is desirable to protect files located on remote +directories, like cloud storages. In order to do this, you might +instruct @value{tramp} to encrypt all files copied to a given remote +directory, and to decrypt such files when accessing. This includes +both file contents and file names. + +@value{tramp} does this transparently. Although both files and file +names are encrypted on the remote side, they are accessible inside +Emacs as they wouldn't be transformed as such. + +@cindex @command{encfs} +@cindex @command{encfsctl} +Internally, @value{tramp} uses the @command{encfs} package. +Therefore, this feature is available only if this package is installed +on the local host. @value{tramp} does not keep and @samp{encfs +mountpoint} permanently. Instead, it encrypts / decrypts files and +file names on the fly, using @command{encfsctl}. + +@deffn Command tramp-crypt-add-directory name +This command marks the existing remote directory @var{name} for +encryption. Files in that directory and all subdirectories will be +encrypted before copying to, and decrypted after copying from that +directory. File and directory names will be also encrypted. +@end deffn + +@defopt tramp-crypt-encfs-option +If a remote directory is marked for encryption, it is initialized via +@command{encfs} the very first time a file in this directory is +accessed. This user option controls, which default @command{encfs} +configuration option will be selected, it can be @t{"--standard"} +or @t{"--paranoia"}. See the @samp{encfs(1)} man page for details. + +However, @value{tramp} must adapt these configuration sets. The +@code{chainedNameIV} configuration option must be disabled; otherwise +@value{tramp} couldn't handle file name encryption transparently. +@end defopt + +A password protected @option{encfs} configuration file is created the +very first time you access an encrypted remote directory. It is kept +in your @code{user-emacs-directory} with the url-encoded directory +name as part of the basename, and @file{encfs6.xml} as suffix. If +you, for example, mark the remote directory +@file{@trampfn{nextcloud,user@@host,/path/to/dir}} for encryption, the +configuration file is saved as +@file{tramp-%2Fnextcloud%3Auser%40host%3A%2Fpath%2Fto%2Fdir%2F.encfs6.xml} +in @code{user-emacs-directory}. Do not loose this file and the +corresponding password; otherwise there is no way to decrypt your +encrypted files. + +@defopt tramp-crypt-save-encfs-config-remote +If this user option is non-nil (the default), the @option{encfs} +configuration file @file{.encfs6.xml} is also kept in the encrypted +remote directory. It depends on you, whether you regard the password +protection of this file as sufficient. The advantage would be, that +such a remote directory could be accessed by different Emacs sessions, +different users, without presharing the configuration file between the +users. +@end defopt + +The command @command{encfsctl}, the workhorse for encryption / +decryption, needs the configuration file password every call. +Therefore, it is recommend to cache this password in Emacs. This can +be done using @code{auth-sources}, @ref{Using an authentication file}. +An entry needs the url-encoded directory name as machine, your local +user name as user, and the password. The port is optional, if given +it must be the string @t{"crypt"}. The example above would require +the following entry in the authentication file (@t{"yourname"} is the +result of @code{(user-login-name)}): + +@example +machine %2Fnextcloud%3Auser%40host%3A%2Fpath%2Fto%2Fdir%2F \ + login yourname port crypt password geheim +@end example + +If you use a remote file name with a quoted localname part, this +localname and the corresponding file will not be encrypted / +decrypted. If you have an encrypted remote directory +@file{@trampfn{nextcloud,user@@host,/path/to/dir}}, the command + +@example +@kbd{C-x d @trampfn{nextcloud,user@@host,/path/to/dir}} +@end example + +@noindent +will show the directory listing with the plain file names, and the +command + +@example +@kbd{C-x d @trampfn{nextcloud,user@@host,/:/path/to/dir}} +@end example + +@noindent +will show the directory listing with the encrypted file names, and +visiting a file will show its encrypted contents. However, it is +highly discouraged to mix encrypted and not encrypted files in the +same directory. + +@deffn Command tramp-crypt-add-directory name +If a remote directory shall not include encrypted files anymore, it +must be indicated by this command. +@end deffn + + @node Windows setup hints @section Issues with Cygwin ssh @cindex cygwin, issues @@ -2665,10 +2799,10 @@ Wiki} it is explained how to use the helper program @cindex @option{scpx} method with cygwin When using the @option{scpx} access method, Emacs may call -@command{scp} with MS Windows file naming, such as @code{c:/foo}. But +@command{scp} with MS Windows file naming, such as @file{c:/foo}. But the version of @command{scp} that is installed with Cygwin does not know about MS Windows file naming, which causes it to incorrectly look -for a host named @code{c}. +for a host named @samp{c}. A workaround: write a wrapper script for @option{scp} to convert Windows file names to Cygwin file names. @@ -2944,10 +3078,10 @@ Example: @end example During file name completion, remote directory contents are re-read -regularly to account for any changes in the filesystem that may affect -the completion candidates. Such re-reads can account for changes to -the file system by applications outside Emacs (@pxref{Connection -caching}). +regularly to account for any changes in the file system that may +affect the completion candidates. Such re-reads can account for +changes to the file system by applications outside Emacs +(@pxref{Connection caching}). @defopt tramp-completion-reread-directory-timeout The timeout is number of seconds since last remote command for @@ -3034,6 +3168,17 @@ host when the variable @code{default-directory} is remote: @end group @end lisp +@vindex process-file-return-signal-string +@code{process-file} shall return either the exit code of the process, +or a string describing the signal, when the process has been +interrupted. Since it cannot be determined reliably whether a remote +process has been interrupted, @code{process-file} returns always the +exit code. When the user option +@code{process-file-return-signal-string} is non-nil, +@code{process-file} regards all exit codes greater than 128 as an +indication that the process has been interrupted, and returns a +respective string. + Remote processes do not apply to @acronym{GVFS} (see @ref{GVFS-based methods}) because the remote file system is mounted on the local host and @value{tramp} just accesses by changing the @@ -3041,9 +3186,17 @@ and @value{tramp} just accesses by changing the @value{tramp} starts a remote process when a command is executed in a remote file or directory buffer. As of now, these packages have been -integrated to work with @value{tramp}: @file{compile.el} (commands -like @code{compile} and @code{grep}) and @file{gud.el} (@code{gdb} or -@code{perldb}). +integrated to work with @value{tramp}: @file{shell.el}, +@file{eshell.el}, @file{compile.el} (commands like @code{compile} and +@code{grep}) and @file{gud.el} (@code{gdb} or @code{perldb}). + +@vindex INSIDE_EMACS@r{, environment variable} +@value{tramp} always modifies the @env{INSIDE_EMACS} environment +variable for remote processes. Per default, this environment variable +shows the Emacs version. @value{tramp} adds its own version string, +so it looks like @samp{27.1,tramp:2.4.3.1}. However, other packages +might also add their name to this environment variable, like +@samp{27.1,comint,tramp:2.4.3.1}. For @value{tramp} to find the command on the remote, it must be accessible through the default search path as setup by @value{tramp} @@ -3168,8 +3321,8 @@ ensures the correct name of the remote shell program. When @code{explicit-shell-file-name} is equal to @code{nil}, calling @code{shell} interactively will prompt for a shell name. -Starting with Emacs 26, you could use connection-local variables for -setting different values of @code{explicit-shell-file-name} for +Starting with @w{Emacs 26}, you could use connection-local variables +for setting different values of @code{explicit-shell-file-name} for different remote hosts. @ifinfo @xref{Connection Variables, , , emacs}. @@ -3238,7 +3391,7 @@ variables. @vindex async-shell-command-width @vindex COLUMNS@r{, environment variable} If Emacs supports the variable @code{async-shell-command-width} (since -Emacs 27.1), @value{tramp} cares about its value for asynchronous +@w{Emacs 27}), @value{tramp} cares about its value for asynchronous shell commands. It specifies the number of display columns for command output. For synchronous shell commands, a similar effect can be achieved by adding the environment variable @env{COLUMNS} to @@ -3725,7 +3878,7 @@ row are possible, like @file{/path/to/dir/file.tar.gz.uu/dir/file}. @vindex tramp-archive-all-gvfs-methods An archive file name could be a remote file name, as in -@file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. +@file{/ftp:anonymous@@ftp.gnu.org:/gnu/tramp/tramp-2.4.3.tar.gz/INSTALL}. Since all file operations are mapped internally to @acronym{GVFS} operations, remote file names supported by @code{tramp-gvfs} perform better, because no local copy of the file archive must be downloaded @@ -3736,7 +3889,7 @@ the similar @samp{/scp:user@@host:...}. See the constant If @code{url-handler-mode} is enabled, archives could be visited via URLs, like -@file{https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/INSTALL}. This +@file{https://ftp.gnu.org/gnu/tramp/tramp-2.4.3.tar.gz/INSTALL}. This allows complex file operations like @lisp @@ -3744,8 +3897,8 @@ allows complex file operations like (progn (url-handler-mode 1) (ediff-directories - "https://ftp.gnu.org/gnu/tramp/tramp-2.3.1.tar.gz/tramp-2.3.1" - "https://ftp.gnu.org/gnu/tramp/tramp-2.3.2.tar.gz/tramp-2.3.2" "")) + "https://ftp.gnu.org/gnu/tramp/tramp-2.4.2.tar.gz/tramp-2.4.2" + "https://ftp.gnu.org/gnu/tramp/tramp-2.4.3.tar.gz/tramp-2.4.3" "")) @end group @end lisp @@ -3860,8 +4013,8 @@ Where is the latest @value{tramp}? @item Which systems does it work on? -The package works successfully on Emacs 24, Emacs 25, Emacs 26, and -Emacs 27. +The package works successfully on @w{Emacs 25}, @w{Emacs 26}, @w{Emacs +27}, and @w{Emacs 28}. While Unix and Unix-like systems are the primary remote targets, @value{tramp} has equal success connecting to other platforms, such as @@ -4123,8 +4276,25 @@ Host * @end group @end example -Check @command{man ssh_config} whether these options are supported on -your proxy host. +Check the @samp{ssh_config(5)} man page whether these options are +supported on your proxy host. + + +@item +@value{tramp} does not connect to Samba or MS Windows hosts running +SMB1 connection protocol. + +@vindex tramp-smb-options +Recent versions of @command{smbclient} do not support old connection +protocols by default. In order to connect to such a host, add a +respective option: + +@lisp +(add-to-list 'tramp-smb-options "client min protocol=NT1") +@end lisp + +@strong{Note} that using a deprecated connection protocol raises +security problems, you should do it only if absolutely necessary. @item @@ -4198,7 +4368,7 @@ Host indication in the mode line? @cindex @value{tramp} theme @vindex tramp-theme-face-remapping-alist -Install @file{tramp-theme} from GNU ELPA via Emacs' Package Manager. +Install @file{tramp-theme} from GNU ELPA via Emacs's Package Manager. Enable it via @kbd{M-x load-theme @key{RET} tramp @key{RET}}. Further customization is explained in user option @code{tramp-theme-face-remapping-alist}. diff --git a/doc/misc/trampver.texi b/doc/misc/trampver.texi index 478ec7037a8..dbebbc36812 100644 --- a/doc/misc/trampver.texi +++ b/doc/misc/trampver.texi @@ -8,9 +8,10 @@ @c In the Tramp GIT, the version numbers are auto-frobbed from @c tramp.el, and the bug report address is auto-frobbed from @c configure.ac. -@set trampver 2.4.3.27.1 +@set trampver 2.5.0-pre +@set trampurl https://www.gnu.org/software/tramp/ @set tramp-bug-report-address tramp-devel@@gnu.org -@set emacsver 24.4 +@set emacsver 25.1 @c Other flags from configuration. @set instprefix /usr/local diff --git a/doc/misc/viper.texi b/doc/misc/viper.texi index 9ce809e7d4d..661eb7c947a 100644 --- a/doc/misc/viper.texi +++ b/doc/misc/viper.texi @@ -1752,10 +1752,10 @@ state. If @code{nil}, the cursor stays where it was before the switch. @item viper-always t @code{t} means: leave it to Viper to decide when a buffer must be brought up in Vi state, -Insert state, or Emacs state. This heuristics works well in virtually all -cases. @code{nil} means you either has to invoke @code{viper-mode} manually +Insert state, or Emacs state. This heuristic works well in virtually all +cases. @code{nil} means you either have to invoke @code{viper-mode} manually for each buffer (or you can add @code{viper-mode} to the appropriate major mode -hooks using @code{viper-load-hook}). +hooks using @code{with-eval-after-load}). This option must be set in your Viper customization file. @item viper-custom-file-name "~/.emacs.d/viper" @@ -1903,9 +1903,6 @@ List of (parameterless) functions called just after entering Replace state @item viper-emacs-state-hook nil List of (parameterless) functions called just after switching from Vi state to Emacs state. -@item viper-load-hook nil -List of (parameterless) functions called just after loading Viper. This is -the last chance to do customization before Viper is up and running. @end table @noindent You can reset some of these constants in Viper with the Ex command @kbd{:set} diff --git a/etc/AUTHORS b/etc/AUTHORS index 2d4e0731202..3e91efb570e 100644 --- a/etc/AUTHORS +++ b/etc/AUTHORS @@ -188,7 +188,7 @@ and changed nsterm.m nsfns.m nsmenu.m nsterm.h font-lock.el nsimage.m Anders Waldenborg: changed emacsclient.c -Andrea Corallo: changed flymake.texi map-tests.el map.el +Andrea Corallo: changed map-tests.el map.el Andrea Rossetti: changed ruler-mode.el @@ -300,7 +300,7 @@ Andrey Slusar: changed gnus-async.el gnus.el Andrey Zhdanov: changed gud.el Andrii Kolomoiets: changed vc-hg.el progmodes/python.el vc-git.el vc.el - cyril-util.el maintaining.texi vc-svn.el + maintaining.texi vc-svn.el Andrzej Lichnerowicz: wrote ob-io.el @@ -421,11 +421,11 @@ Bartosz Duszel: changed allout.el bib-mode.el cc-cmds.el hexl.el icon.el sendmail.el ses.el simple.el verilog-mode.el vi.el vip.el viper-cmd.el xscheme.el -Basil L. Contovounesios: changed simple.el message.el subr.el text.texi - gravatar.el modes.texi custom.el customize.texi display.texi eww.el - files.texi gnus-group.el gnus-sum.el gnus-win.el internals.texi - window.c bibtex.el button.el gnus-art.el gnus-msg.el gnus.texi - and 182 other files +Basil L. Contovounesios: changed simple.el message.el subr.el gravatar.el + custom.el gnus-group.el gnus-sum.el gnus-win.el internals.texi + modes.texi text.texi window.c bibtex.el button.el customize.texi + display.texi eww.el gnus-art.el gnus-msg.el gnus.texi lists.texi + and 150 other files Bastian Beischer: changed semantic/complete.el include.el mru-bookmark.el refs.el senator.el @@ -511,8 +511,6 @@ and changed mh-customize.el mh-search.el mh-alias.el mh-e.texi Makefile Bjarte Johansen: wrote ob-sed.el -Björn Holby: changed vhdl-mode.el - Björn Lindström: changed rcirc.texi Bjørn Mork: changed nnimap.el gnus-agent.el message.el mml2015.el @@ -837,7 +835,7 @@ Claudio Fontana: changed Makefile.in leim/Makefile.in lib-src/Makefile.in Clément Pit--Claudel: changed debugging.texi emacs-lisp/debug.el eval.c progmodes/python.el subr-tests.el subr.el url-http.el url-vars.el -Clément Pit-Claudel: changed display.texi keyboard.c text.texi xdisp.c +Clément Pit-Claudel: changed keyboard.c text.texi Colin Marquardt: changed gnus.el message.el @@ -1291,9 +1289,9 @@ Dmitry Gutov: wrote elisp-mode-tests.el jit-lock-tests.el json-tests.el vc-hg-tests.el xref-tests.el and changed ruby-mode.el xref.el project.el vc-git.el elisp-mode.el etags.el ruby-mode-tests.el js.el package.el vc-hg.el vc.el - symref/grep.el log-edit.el simple.el dired-aux.el minibuffer.el + symref/grep.el log-edit.el dired-aux.el simple.el minibuffer.el menu-bar.el package-test.el progmodes/grep.el vc-svn.el eldoc.el - and 112 other files + and 111 other files Dmitry Kurochkin: changed isearch.el @@ -1379,9 +1377,9 @@ Eli Zaretskii: wrote [bidirectional display in xdisp.c] chartab-tests.el coding-tests.el doc-tests.el etags-tests.el rxvt.el tty-colors.el and changed xdisp.c msdos.c w32.c display.texi w32fns.c simple.el - files.el fileio.c keyboard.c w32term.c emacs.c w32proc.c files.texi + files.el fileio.c keyboard.c w32term.c w32proc.c emacs.c files.texi text.texi dispnew.c frames.texi lisp.h dispextern.h window.c process.c - term.c and 1191 other files + term.c and 1188 other files Emanuele Giaquinta: changed configure.ac rxvt.el charset.c etags.c fontset.c frame.el gnus-faq.texi loadup.el lread.c sh-script.el @@ -2083,8 +2081,6 @@ Jaesup Kwak: changed xwidget.c Jaeyoun Chung: changed hangul3.el hanja3.el gnus-mule.el hangul.el -Jakub-W: changed calculator.el - Jambunathan K: wrote ox-odt.el and co-wrote ox-html.el and changed org-lparse.el org.el org.texi ox.el icomplete.el @@ -2371,8 +2367,8 @@ João Távora: wrote elec-pair.el electric-tests.el flymake-cc.el and changed flymake.el flymake-proc.el icomplete.el minibuffer.el flymake-tests.el flymake.texi elisp-mode.el flymake-elisp.el electric.el flymake-ui.el text.texi json-tests.el tex-mode.el - errors-and-warnings.c json.c xref.el auth-source-pass.el buffers.texi - linum.el maintaining.texi message.el and 30 other files + errors-and-warnings.c json.c xref.el auth-source-pass.el linum.el + maintaining.texi message.el progmodes/python.el and 30 other files Jochen Hein: changed gnus-art.el @@ -2650,8 +2646,8 @@ and changed tramp-gvfs.el tramp-sh.el comint.el em-unix.el esh-util.el Juri Linkov: wrote files-x.el misearch.el replace-tests.el tab-bar.el tab-line.el and changed isearch.el info.el simple.el replace.el dired.el dired-aux.el - progmodes/grep.el image-mode.el progmodes/compile.el startup.el subr.el - diff-mode.el files.el menu-bar.el faces.el display.texi bindings.el + progmodes/grep.el progmodes/compile.el startup.el subr.el diff-mode.el + files.el menu-bar.el faces.el bindings.el display.texi image-mode.el desktop.el comint.el minibuffer.el search.texi and 419 other files Jussi Lahdenniemi: changed w32fns.c ms-w32.h msdos.texi w32.c w32.h @@ -3048,8 +3044,6 @@ Leonard Randall: changed org-bibtex.el reftex-parse.el Leo P. White: changed eieio-custom.el -Leo Vivier: changed dired-aux.el - Levin Du: changed parse-time.el org-clock.el Le Wang: changed org-src.el comint.el hilit-chg.el misc.el @@ -3073,8 +3067,8 @@ Luca Capello: changed mm-encode.el Lucas Werkmeister: changed emacs.c emacs.service Lucid, Inc.: changed byte-opt.el byte-run.el bytecode.c bytecomp.el - delsel.el disass.el faces.el font-lock.el lmenu.el mailabbrev.el - select.el xfaces.c xselect.c + delsel.el disass.el faces.el font-lock.el mailabbrev.el select.el + xfaces.c xselect.c Luc Teirlinck: wrote help-at-pt.el and changed files.el autorevert.el cus-edit.el subr.el simple.el @@ -3375,7 +3369,7 @@ Matthias Dahl: changed faces.el process.c process.h Matthias Förste: changed files.el Matthias Meulien: changed bookmark.el progmodes/python.el buff-menu.el - prog-mode.el simple.el tab-bar.el tabify.el vc-dir.el vc-git.el + prog-mode.el simple.el tabify.el vc-dir.el vc-git.el Matthias Wiehl: changed gnus.el @@ -3394,7 +3388,7 @@ Mattias Engdegård: changed rx.el searching.texi rx-tests.el autorevert.el calc-tests.el regexp-opt.el filenotify.el subr.el files.el progmodes/compile.el mouse.el bytecomp.el compile-tests.el autorevert-tests.el byte-opt.el bytecomp-tests.el calc-alg.el - compilation.txt dired.el font.c regex-emacs.c and 170 other files + compilation.txt dired.el font.c regex-emacs.c and 161 other files Matt Lundin: changed org-agenda.el org.el org-bibtex.el org-footnote.el ox-publish.el org-bbdb.el org-datetree.el org-gnus.el @@ -3425,14 +3419,14 @@ Micah Anderson: changed spook.lines Michael Albinus: wrote autorevert-tests.el dbus-tests.el dbus.el filenotify-tests.el filenotify.el files-x-tests.el secrets-tests.el secrets.el shadowfile-tests.el tramp-archive-tests.el tramp-archive.el - tramp-cmds.el tramp-compat.el tramp-ftp.el tramp-gvfs.el + tramp-cmds.el tramp-compat.el tramp-crypt.el tramp-ftp.el tramp-gvfs.el tramp-integration.el tramp-rclone.el tramp-smb.el tramp-sudoedit.el tramp-tests.el url-tramp-tests.el url-tramp.el vc-tests.el zeroconf.el and co-wrote tramp-cache.el tramp-sh.el tramp.el and changed tramp.texi tramp-adb.el trampver.el trampver.texi dbusbind.c file-notify-tests.el files.el ange-ftp.el files.texi dbus.texi autorevert.el tramp-fish.el kqueue.c tramp-gw.el tramp-imap.el os.texi - xesam.el configure.ac lisp.h shell.el gfilenotify.c and 254 other files + xesam.el configure.ac lisp.h shell.el gfilenotify.c and 253 other files Michael Ben-Gershon: changed acorn.h configure.ac riscix1-1.h riscix1-2.h unexec.c @@ -3814,7 +3808,7 @@ Noam Postavsky: changed progmodes/python.el lisp-mode.el bytecomp.el lisp-mode-tests.el term.el xdisp.c eval.c cl-macs.el data.c emacs-lisp/debug.el simple.el help-fns.el modes.texi subr.el elisp-mode.el ert.el isearch.el processes.texi cl-print.el diff-mode.el - ffap.el and 360 other files + ffap.el and 359 other files Nobuyoshi Nakada: co-wrote ruby-mode.el and changed ruby-mode-tests.el @@ -3922,9 +3916,9 @@ and changed imenu.el make-mode.el Paul Eggert: wrote rcs2log and co-wrote cal-dst.el and changed lisp.h configure.ac alloc.c process.c fileio.c editfns.c - xdisp.c sysdep.c image.c keyboard.c emacs.c data.c fns.c lread.c + xdisp.c sysdep.c image.c keyboard.c data.c emacs.c fns.c lread.c xterm.c eval.c callproc.c Makefile.in frame.c buffer.c gnulib-comp.m4 - and 1822 other files + and 1813 other files Paul Fisher: changed fns.c @@ -4108,13 +4102,13 @@ Philipp Stephani: wrote callint-tests.el checkdoc-tests.el cl-preloaded-tests.el ediff-diff-tests.el eval-tests.el ido-tests.el lread-tests.el mouse-tests.el startup-tests.el xt-mouse-tests.el and changed emacs-module.c emacs-module-tests.el json.c json-tests.el - mod-test.c eval.c lisp.h lread.c nsterm.m configure.ac bytecomp.el - internals.texi gtkutil.c emacs-module.h.in files.el alloc.c editfns.c - electric-tests.el electric.el test/Makefile.in emacs.c - and 129 other files + eval.c mod-test.c lisp.h lread.c nsterm.m configure.ac bytecomp.el + internals.texi gtkutil.c emacs-module.h.in files.el alloc.c + electric-tests.el electric.el test/Makefile.in editfns.c emacs.c + and 127 other files Phillip Lord: wrote ps-print-tests.el -and changed build-zips.sh lisp/Makefile.in build-dep-zips.py undo.c +and changed build-zips.sh lisp/Makefile.in undo.c build-dep-zips.py simple.el test/Makefile.in Makefile Makefile.in emacs.nsi keyboard.c viper-cmd.el README-windows-binaries README.W32 elisp-mode-tests.el ldefs-clean.el loadup.el README-scripts autoload.el @@ -4154,10 +4148,10 @@ Piotr Trojanek: changed gnutls.c process.c Piotr Zieliński: wrote org-mouse.el -Pip Cet: changed fns.c display.texi xdisp.c xterm.c composite.c - dispextern.h frame.el gtkutil.c image.c indent.c json-tests.el json.c - mail-utils.el nsterm.m simple.el subr.el text.texi textprop.c - timer-list.el tty-colors-tests.el tty-colors.el and 4 other files +Pip Cet: changed fns.c display.texi xdisp.c xterm.c dispextern.h frame.el + gtkutil.c image.c json-tests.el json.c mail-utils.el nsterm.m simple.el + subr.el text.texi textprop.c timer-list.el tty-colors-tests.el + tty-colors.el url-http.el xfaces.c xterm.h Pontus Michael: changed simple.el @@ -4195,8 +4189,7 @@ Rajappa Iyer: changed gnus-salt.el Raja R. Harinath: changed gnus-salt.el nnml.el -Rajesh Vaidheeswarran: wrote old-whitespace.el -and changed whitespace.el ffap.el +Rajesh Vaidheeswarran: changed whitespace.el ffap.el Ralf Angeli: wrote scroll-lock.el and changed w32fns.c reftex-cite.el gnus-art.el reftex-toc.el reftex.el @@ -4269,7 +4262,7 @@ Ricardo Wurmus: changed xwidget.el xwidget.c configure.ac xwidget.h Riccardo Murri: changed vc-bzr.el tls.el -Richard Copley: changed Makefile.in epaths.in epaths.nt gdb-mi.el sort.el +Richard Copley: changed Makefile.in epaths.in epaths.nt gdb-mi.el text.texi Richard Dawe: changed config.in src/Makefile.in @@ -4279,7 +4272,7 @@ Richard G. Bielawski: changed modes.texi paren.el Richard Hoskins: changed message.el Richard Kim: wrote wisent/python.el -and changed bovine.texi db-global.el gud.el loading.texi python-wy.el +and changed bovine.texi db-global.el loading.texi python-wy.el texnfo-upd.el wisent.texi Richard King: wrote filelock.c uniquify.el userlock.el @@ -4355,9 +4348,9 @@ Robert P. Goldman: changed org.texi ob-exp.el org.el ox-latex.el Robert Pluim: wrote nsm-tests.el and changed process.c ftfont.c gtkutil.c processes.texi vc-git.el configure.ac font.c network-stream.el nsm.el process-tests.el xfns.c - custom.texi dispextern.h files.texi ftcrfont.c gnus-icalendar.el - gnutls.el gtkutil.h network-stream-tests.el nsterm.m text.texi - and 92 other files + dispextern.h files.texi ftcrfont.c gnus-icalendar.el gnutls.el + gtkutil.h network-stream-tests.el nsterm.m text.texi w32.c + and 90 other files Robert Thorpe: changed cus-start.el indent.el @@ -4648,9 +4641,12 @@ Sidney Markowitz: changed doctor.el nsmenu.m Sigbjorn Finne: changed gnus-srvr.el -Simen Heggestøyl: wrote asm-mode-tests.el autoinsert-tests.el - color-tests.el css-mode-tests.el dom-tests.el makesum-tests.el - page-tests.el paren-tests.el ring-tests.el rot13-tests.el sql-tests.el +Simen Heggestøyl: wrote apropos-tests.el asm-mode-tests.el + autoconf-tests.el autoinsert-tests.el check-declare-tests.el + color-tests.el css-mode-tests.el dom-tests.el elide-head-tests.el + glasses-tests.el help-mode-tests.el makesum-tests.el page-tests.el + paren-tests.el po-tests.el ring-tests.el rot13-tests.el sql-tests.el + webjump-tests.el and changed css-mode.el css-mode.css json-tests.el json.el sgml-mode.el scss-mode.scss page.el ring.el rot13.el scheme.el sql.el asm-mode.el autoinsert.el color.el files.el js.el less-css-mode.el @@ -4660,8 +4656,9 @@ and changed css-mode.el css-mode.css json-tests.el json.el sgml-mode.el Simona Arizanova: changed help.el Simon Josefsson: wrote dig.el dns-mode.el flow-fill.el fringe.el imap.el - mml-sec.el mml-smime.el password-cache.el rfc2104.el sieve-mode.el - sieve.el smime.el starttls.el tls.el url-imap.el + mml-sec.el mml-smime.el password-cache.el rfc2104.el + sasl-scram-sha256.el sieve-mode.el sieve.el smime.el starttls.el tls.el + url-imap.el and co-wrote gnus-sieve.el gssapi.el mml1991.el nnfolder.el nnimap.el nnml.el sieve-manage.el and changed message.el gnus-sum.el gnus-art.el smtpmail.el pgg-gpg.el @@ -4670,8 +4667,6 @@ and changed message.el gnus-sum.el gnus-art.el smtpmail.el pgg-gpg.el gnus-int.el gnus.el hashcash.el mm-view.el password.el and 101 other files -Simon Lang: changed misterioso-theme.el - Simon Law: changed delsel.el electric.el Simon Leinen: changed Makefile.in smtpmail.el Makefile cm.c cm.h hpux9.h @@ -4711,13 +4706,15 @@ Stefan Bruda: co-wrote prolog.el Stefan Guath: changed find-dired.el -Stefan Kangas: wrote bookmark-tests.el delim-col-tests.el morse-tests.el - paragraphs-tests.el password-cache-tests.el studly-tests.el - tabify-tests.el timezone-tests.el underline-tests.el uudecode-tests.el +Stefan Kangas: wrote bookmark-tests.el cal-julian-tests.el + delim-col-tests.el lunar-tests.el misc-tests.el morse-tests.el + paragraphs-tests.el password-cache-tests.el qp-tests.el + rfc2045-tests.el studly-tests.el tabify-tests.el timezone-tests.el + underline-tests.el uudecode-tests.el and changed bookmark.el package.el efaq.texi package.texi ibuffer.el mwheel.el cperl-mode.el fns.c gud.el simple.el subr.el autoinsert.el - comint-tests.el control.texi cus-edit.el delim-col.el dired-aux.el - dired-x.el em-term.el ert.texi flow-fill.el and 152 other files + comint-tests.el cus-edit.el delim-col.el dired-aux.el dired-x.el + em-term.el ert.texi flow-fill.el frames.texi and 147 other files Stefan Merten: co-wrote rst.el @@ -4733,7 +4730,7 @@ and co-wrote font-lock.el gitmerge.el pcvs.el and changed subr.el simple.el keyboard.c bytecomp.el files.el lisp.h cl-macs.el vc.el xdisp.c alloc.c eval.c sh-script.el progmodes/compile.el keymap.c tex-mode.el buffer.c newcomment.el - window.c lread.c fileio.c help-fns.el and 1373 other files + window.c lread.c fileio.c help-fns.el and 1372 other files Stefano Facchini: changed gtkutil.c @@ -4752,9 +4749,10 @@ Stefan Wiens: changed gnus-sum.el Steinar Bang: changed gnus-setup.el imap.el Štěpán Němec: changed INSTALL calc-ext.el checkdoc.el cl.texi comint.el - edebug.texi font-lock.el functions.texi gnus-sum.el gnus.texi insdel.c + edebug.texi font-lock.el functions.texi gnus-sum.el insdel.c leim-ext.el loading.texi maps.texi mark.texi message.texi mini.texi - minibuf.texi misc.texi programs.texi subr.el and 8 other files + minibuf.texi misc.texi programs.texi subr.el text.texi + and 7 other files Stephan Stahl: changed which-func.el buff-menu.el buffer.c dired-x.texi ediff-mult.el @@ -4767,7 +4765,7 @@ and changed wdired.el todo-mode.texi diary-lib.el wdired-tests.el dired-tests.el doc-view.el files.el minibuffer.el dired.el frames.texi hl-line.el info.el menu-bar.el mouse.el otodo-mode.el subr.el .gitattributes TUTORIAL allout.el artist.el compile.texi - and 44 other files + and 43 other files Stephen C. Gilardi: changed configure.ac @@ -4919,7 +4917,7 @@ and changed reftex-vars.el tex-mode.el gnus.texi reftex-cite.el tsdh-dark-theme.el tsdh-light-theme.el gnus-sum.el file-notify-tests.el reftex.el misc.texi org-gnus.el prog-mode.el subword.el image-mode.el json.el lisp-mode.el cc-cmds.el display.texi em-term.el emacsbug.el - files.el and 83 other files + files.el and 82 other files Tatsuya Ichikawa: changed gnus-agent.el gnus-cache.el @@ -5472,6 +5470,8 @@ Yuan Fu: changed gdb-mi.el Yuanle Song: changed rng-xsd.el +Yue Daian: wrote cl-font-lock.el + Yu-ji Hosokawa: changed README.W32 Yukihiro Matsumoto: co-wrote ruby-mode.el @@ -6,10 +6,10 @@ See the end of the file for license conditions. Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'. If possible, use 'M-x report-emacs-bug'. -This file is about changes in Emacs version 27. +This file is about changes in Emacs version 28. See file HISTORY for a list of GNU Emacs versions and release dates. -See files NEWS.26, NEWS.25, ..., NEWS.18, and NEWS.1-17 for changes +See files NEWS.27, NEWS.26, ..., NEWS.18, and NEWS.1-17 for changes in older Emacs versions. You can narrow news to a specific version by calling 'view-emacs-news' @@ -22,3164 +22,749 @@ When you add a new item, use the appropriate mark if you are sure it applies, and please also update docstrings as needed. -* Installation Changes in Emacs 27.1 +* Installation Changes in Emacs 28.1 + +** Cairo graphics library is now used by default if found. +'--with-cairo' is now the default, if the appropriate development files +are found by 'configure'. Note that building with Cairo means using +Pango instead of libXFT for font support. Since Pango 1.44 has +removed support for bitmapped fonts, this may require you to adjust +your font settings. + +Note also that 'FontBackend' settings in ".Xdefaults" or +".Xresources", or 'font-backend' frame parameter settings in your init +files, may need to be adjusted, as 'xft' is no longer a valid backend +when using Cairo. Use 'ftcrhb' if your Emacs was built with HarfBuzz +text shaping support, and 'ftcr' otherwise. You can determine this by +checking 'system-configuration-features'. The 'ftcr' backend will +still be available when HarfBuzz is supported, but will not be used by +default. We strongly recommend building with HarBuzz support. 'x' is +still a valid backend. --- -** Emacs now uses GMP, the GNU Multiple Precision library. -By default, if 'configure' does not find a suitable libgmp, it -arranges for the included mini-gmp library to be built and used. -The new configure option '--without-libgmp' uses mini-gmp even if a -suitable libgmp is available. - -** Emacs can now use HarfBuzz as its shaping engine. -The new configure option '--with-harfbuzz' adds support for the -HarfBuzz text shaping engine. It is on by default; use './configure ---without-harfbuzz' to build without it. The HarfBuzz text shaping is -available via new font backend drivers 'xfthb' and 'ftcrhb' for Xft -and Cairo drawings, respectively, and via the 'harfbuzz' backend on -MS-Windows. The HarfBuzz text shaping is preferred to the previously -supported ones, so the font backends that use older shaping engines -(FLT on GNU and Unix systems and Uniscribe on MS-Windows) are not -enabled by default; they can be enabled via the 'font-backend' frame -parameter or via X resources. - -** The new configure option '--with-json' adds native support for JSON. -This uses the Jansson library. The option is on by default; use -'./configure --with-json=no' to build without Jansson support. The -new JSON functions 'json-serialize', 'json-insert', -'json-parse-string', and 'json-parse-buffer' are typically much faster -than their Lisp counterparts from json.el. - -** The configure option '--with-cairo' is no longer experimental. -This builds Emacs with Cairo drawing, and supports built-in printing -when Emacs is built with GTK+. Some severe bugs in this build were -fixed, and we can therefore offer this to users without caveats. Note -that building with Cairo enabled results in using Pango instead of -libXft for font support, and that Pango 1.44 has removed support for -bitmapped fonts. +** 'configure' now warns about building with libXft support. +libXft is unmaintained, and causes a number of problems with modern +fonts including but not limited to crashes; support for it may be +removed in a future version of Emacs. Please consider using +Cairo + HarfBuzz instead. -+++ -** Emacs now uses a "portable dumper" instead of unexec. -This improves compatibility with memory allocation on modern systems, -and in particular better supports the Address Space Layout -Randomization (ASLR) feature, a security technique used by most modern -operating systems. - -When built with the portable dumping support (which is the default), -Emacs looks for the "emacs.pdmp" file, generated during the build, in -its data directory at startup, and loads the dumped state from there. -The new command-line argument '--dump-file=FILE' allows specifying a -non-default ".pdmp" file to load the state from; see the node -"(emacs) Initial Options" in the Emacs manual for more information. - -An Emacs started via a dump file can create a new dump file only if it -was invoked with the '-batch' option. (This is a temporary -limitation; we plan on lifting it in a future release.) - -Although the portable dumper has been tested, it may have a bug on -unusual platforms. If you require traditional unexec dumping you can -use the configure-time option '--with-dumping=unexec'; however, please -file a bug report describing the situation, as unexec dumping is -deprecated, and we plan on removing it in some future release. - -** The new configure option '--enable-checking=structs' attempts to -check that the portable dumper code has been updated to match the last -change to one of the data structures that it relies on. - -** The configure options '--enable-checking=conslist' and -'--enable-checking=xmallocoverrun' have been withdrawn. The former -made Emacs irredeemably slow, and the latter made it crash. Neither -option was useful with modern debugging tools such as AddressSanitizer. -(See "etc/DEBUG" for the details of using the modern replacements of the -removed configure options.) - -** Emacs no longer defaults to using ImageMagick to display images. -This is due to security and stability concerns with ImageMagick. To -override the default, use 'configure --with-imagemagick'. - -** Several configure options now accept an option-argument 'ifavailable'. -For example, './configure --with-xpm=ifavailable' now configures Emacs -to attempt to use libxpm but to continue building even if libxpm is -absent. The other affected options are '--with-gif', '--with-gnutls', -'--with-jpeg', '--with-png', and '--with-tiff'. - -** The 'etags' program now uses the C library's regular expression matcher. -If it's possible, 'etags' will use the regexp matcher from the -system's standard C library, otherwise it will be linked with a -compatible regex substitute. This lets developers maintain Emacs's -own regex code without having to also support other programs. The new -configure option '--without-included-regex' forces 'etags' to use the C -library's regex matcher even if the regex substitute ordinarily would -be used to work around compatibility problems. - -** Emacs has been ported to the '-fcheck-pointer-bounds' option of GCC. -This causes Emacs to check bounds of some arrays addressed by its -internal pointers, which can be helpful when debugging the Emacs -interpreter or modules that it uses. If your platform supports it you -can enable it when configuring, e.g., './configure CFLAGS="-g3 -O2 --mmpx -fcheck-pointer-bounds"' on Intel MPX platforms. - -** Emacs now normally uses a C pointer type instead of a C integer -type to implement Lisp_Object, which is the fundamental machine word -type internal to the Emacs Lisp interpreter. This change aims to -catch typos and supports '-fcheck-pointer-bounds'. The configure -option '--enable-check-lisp-object-type' is therefore no longer as -useful and so is no longer enabled by default in developer builds, -to reduce differences between developer and production builds. - -** The distribution tarball now has test cases; 'make check' runs them. -This is intended mostly to help developers. - -** Emacs now requires GTK 2.24 and GTK 3.10 for the GTK 2 and GTK 3 -builds respectively. - -** New make target 'help' shows a summary of common make targets. - -** Emacs now builds with dynamic module support by default. -Pass '--without-modules' to 'configure' to disable dynamic module -support. - -** The ftx font backend driver is now obsolete and will be removed in -Emacs 28. - - -* Startup Changes in Emacs 27.1 - -** Emacs can now use the XDG convention for init files. -The 'XDG_CONFIG_HOME' environment variable (which defaults to -"~/.config") specifies the XDG configuration parent directory. Emacs -checks for "init.el" and other configuration files inside the "emacs" -subdirectory of 'XDG_CONFIG_HOME', i.e. "$XDG_CONFIG_HOME/emacs/init.el" - -However, Emacs will still initially look for init files in their -traditional locations if "~/.emacs.d" or "~/.emacs" exist, even if -"$XDG_CONFIG_HOME/emacs" also exists. This means that you must delete -or rename any existing "~/.emacs.d" and "~/.emacs" to enable use of -the XDG directory. - -If "~/.emacs.d" does not exist, and Emacs has decided to use it -(i.e. "$XDG_CONFIG_HOME/emacs" does not exist), Emacs will create it. -Emacs will never create "$XDG_CONFIG_HOME/emacs". - -Whichever directory Emacs decides to use, it will set -'user-emacs-directory' to point to it. - -** Emacs can now be configured using an early init file. -The file is called "early-init.el", in 'user-emacs-directory'. It is -loaded very early in the startup process: before graphical elements -such as the tool bar are initialized, and before the package manager -is initialized. The primary purpose is to allow customizing how the -package system is initialized given that initialization now happens -before loading the regular init file (see below). - -We recommend against putting any customizations in this file that -don't need to be set up before initializing installed add-on packages, -because the early init file is read too early into the startup -process, and some important parts of the Emacs session, such as -'window-system' and other GUI features, are not yet set up, which could -make some customization fail to work. - -** Installed packages are now activated *before* loading the init file. -As a result of this change, it is no longer necessary to call -'package-initialize' in your init file. - -Previously, a call to 'package-initialize' was automatically inserted -into the init file when Emacs was started. This call can now safely -be removed. Alternatively, if you want to ensure that your init file -is still compatible with earlier versions of Emacs, change it to: - -(when (< emacs-major-version 27) - (package-initialize)) - -However, if your init file changes the values of 'package-load-list' -or 'package-user-dir', or sets 'package-enable-at-startup' to nil then -it won't work right without some adjustment: -- You can move that code to the early init file (see above), so those - settings apply before Emacs tries to activate the packages. -- You can use the new 'package-quickstart' so activation of packages - does not need to pay attention to 'package-load-list' or - 'package-user-dir' any more. - -** Emacs now notifies systemd when startup finishes or shutdown begins. -Units that are ordered after 'emacs.service' will only be started -after Emacs has finished initialization and is ready for use. -(If your Emacs is installed in a non-standard location and you copied the -emacs.service file to e.g. "~/.config/systemd/user/", you will need to copy -the new version of the file again.) - - -* Changes in Emacs 27.1 - -** Emacs now supports Unicode Standard version 13.0. - -** Emacs now supports resizing and rotating images without ImageMagick. -All modern systems support this feature. (On GNU and Unix systems, -Cairo drawing or the XRender extension to X11 is required for this to -be available; the configure script will test for it and, if found, -enable scaling.) - -The new function 'image-transforms-p' can be used to test whether any -given frame supports these capabilities. - -** The Network Security Manager now allows more fine-grained control -of what checks to run via the 'network-security-protocol-checks' -user option. - -** TLS connections have their security tightened by default. -Most of the checks for outdated, believed-to-be-weak TLS algorithms -and ciphers are now switched on by default. (In addition, several new -TLS weaknesses are now warned about.) By default, the NSM will -flag connections using these weak algorithms and ask users whether to -allow them. To get the old behavior back (where certificates are -checked for validity, but no warnings about weak cryptography are -issued), you can either set 'network-security-protocol-checks' to nil, -or adjust the elements in that user option to only happen on the 'high' -security level (assuming you use the 'medium' level). - -** New user option 'nsm-trust-local-network'. -Allows skipping Network Security Manager checks for hosts on your -local subnet(s). It defaults to nil. Usually, there should be no -need to set this non-nil, and doing that risks opening your local -network connections to attacks. So be sure you know what you are -doing before changing the value. - -** Native GnuTLS connections can now use client certificates. -Previously, this support was only available when using the external -'gnutls-cli' or 'starttls' command. Call 'open-network-stream' with -':client-certificate t' to trigger looking up of per-server -certificates via 'auth-source'. - -** New user option 'network-stream-use-client-certificates'. -When non-nil, 'open-network-stream' performs lookups of client -certificates using 'auth-source' as if ':client-certificate t' were -specified if there is no explicit ':client-certificate' parameter. -Defaults to nil. - -** 'next/previous-multiframe-window' have been renamed. -The new names are as follows: - - 'next-multiframe-window' -> 'next-window-any-frame' - 'previous-multiframe-window' -> 'previous-window-any-frame' - -The old function names are maintained as aliases for backward -compatibility. - -** emacsclient -*** emacsclient now supports the 'EMACS_SOCKET_NAME' environment variable. -The command-line argument '--socket-name' overrides it. -(The same behavior as for the pre-existing 'EMACS_SERVER_FILE' variable.) - -*** Emacs and emacsclient now default to "$XDG_RUNTIME_DIR/emacs". -This is used as the directory for client/server sockets, if Emacs is -running on a platform or environment that sets the 'XDG_RUNTIME_DIR' -environment variable to indicate where session sockets should go. -To get the old, less-secure behavior, you can set the -'EMACS_SOCKET_NAME' environment variable to an appropriate value. - -*** When run by root, emacsclient no longer connects to non-root sockets. -(Instead you can use Tramp methods to run root commands in a non-root Emacs.) - -** 'xft-ignore-color-fonts' now ignores even more color fonts. -There are color fonts that managed to bypass the existing checks, -causing XFT crashes, they are now filtered out. Setting -'xft-ignore-color-fonts' to nil removes those checks, which might -require setting 'face-ignored-fonts' to filter out problematic fonts. -Known problematic fonts are "Noto Color Emoji" and "Emoji One". - -** The GTK+ font chooser now respects 'face-ignored-fonts'. -When using 'menu-set-font' under GTK3, the available fonts are now -matched against 'face-ignored-fonts'. - -** The GTK+ font chooser now remembers the previously selected settings. -It now remembers the name, size, style, etc. - -** New user option 'what-cursor-show-names'. -When non-nil, 'what-cursor-position' will show the name of the character -in addition to the decimal/hex/octal representation. Default nil. - -** New function 'network-lookup-address-info'. -This does IPv4 and/or IPv6 address lookups on hostnames. - -** 'network-interface-list' can now return IPv4 and IPv6 addresses. -IPv4 and IPv6 addresses are now returned by default if available, -optionally including netmask/broadcast address information. - -** Control of the threshold for using the 'distant-foreground' color. -The threshold for color distance below which the 'distant-foreground' -color of the face will be used instead of the foreground color can now -be controlled via the new variable 'face-near-same-color-threshold'. -The default value is 30000, as the previously hard-coded threshold. - -** The function 'read-passwd' uses "*" as default character to hide passwords. - -** The function 'read-answer' now accepts not only single character -answers, but also function keys like 'F1', character events such as -'C-M-h', and control characters like 'C-h'. - -** Lexical binding is now used by default when evaluating interactive Elisp. -More specifically, 'lexical-binding' is now used by default for 'M-:' -and '--eval' (including in evaluations invoked from 'emacsclient' via -its '--eval' command-line option), as well as in -'lisp-interaction-mode' and 'ielm-mode', used in the "*scratch*" and -"*ielm*" buffers. - -We envision that most Lisp code is already either written with -lexical-binding in mind, or will work unchanged under -lexical-binding. If, for some reason, your code used in 'M-:' or -'--eval' doesn't work as result of this change, either modify the code -to work with lexical binding, or wrap it in an extra level of 'eval'. -For example, --eval "FORM" becomes --eval "(eval 'FORM)" (note the extra -quote in 'FORM). - -** The new user option 'tooltip-resize-echo-area' avoids truncating -tooltip text on GUI frames when tooltips are displayed in the echo -area. Instead, it resizes the echo area as needed to accommodate the -full tool-tip text. - -** Show mode line tooltips only if the corresponding action applies. -Customize the user option 'mode-line-default-help-echo' to restore the -old behavior where the tooltip text is also shown when the -corresponding action does not apply. - -** New hook 'server-after-make-frame-hook'. -This hook is a convenient place to perform initializations in daemon -mode which require GUI features to be available. One example is -restoration of the previous session using the desktop.el package: put -the call to 'desktop-read' in this hook, if you want the GUI settings -to be restored, or if desktop.el needs to interact with you during -restoration of the session. - -** The functions 'set-frame-height' and 'set-frame-width' are now -commands, and will set the currently selected frame to the height/ -width specified by the numeric prefix. - -** New function 'logcount' calculates an integer's Hamming weight. - -** New function 'libxml-available-p'. -This function returns non-nil if libxml support is both compiled in -and available at run time. Lisp programs should use this function to -detect built-in libxml support, instead of testing for that -indirectly, e.g., by checking that functions like -'libxml-parse-html-region' return nil. - -** 'libxml-parse-xml-region' and 'libxml-parse-html-region' take -a parameter that's called DISCARD-COMMENTS, but it really only -discards the top-level comment. Therefore this parameter is now -obsolete, and the new utility function 'xml-remove-comments' can be -used to remove comments before calling the libxml functions to parse -the data. - -** A new DOM (the XML/HTML document structure returned by functions -such as 'libxml-parse-html-region') traversal function has been added: -'dom-search', which takes a DOM and a predicate and returns all nodes -that match. - -** New function 'fill-polish-nobreak-p', to be used in 'fill-nobreak-predicate'. -It blocks line breaking after a one-letter word, also in the case when -this word is preceded by a non-space, but non-alphanumeric character. - -** The limit on repetitions in regexps has been raised to 2^16-1. -It was previously limited to 2^15-1. For example, the following -regular expression was previously invalid, but is now accepted: - - x\{32768\} - -** The German prefix and postfix input methods now support Capital sharp S. - -** New input methods 'hawaiian-postfix' and 'hawaiian-prefix'. - -** New input methods 'georgian-qwerty' and 'georgian-nuskhuri'. - -** New input methods for several variants of the Sami language. -The Sami input methods include: 'norwegian-sami-prefix', -'bergsland-hasselbrink-sami-prefix', 'southern-sami-prefix', -'ume-sami-prefix', 'northern-sami-prefix', 'inari-sami-prefix', -'skolt-sami-prefix', and 'kildin-sami-prefix'. - -** Japanese environments use UTF-8 by default. -In Japanese environments that do not specify encodings and are not -based on MS-Windows, the default encoding is now utf-8 instead of -japanese-iso-8bit. - -** New function 'exec-path'. -This function by default returns the value of the corresponding -user option, but can optionally return the equivalent of 'exec-path' -from a remote host. - -** The function 'executable-find' supports an optional argument REMOTE. -This triggers searching for the program on the remote host as indicated by -'default-directory'. - -** New user option 'auto-save-no-message'. -When set to t, no message will be shown when auto-saving (default -value: nil). - -** The value of 'make-cursor-line-fully-visible' can now be a function. -In addition to nil or non-nil, the value can now be a predicate -function. Follow mode uses this to control scrolling of its windows -when the last screen line in a window is not fully visible. - -** New variable 'emacs-repository-branch'. -It reports the git branch from which Emacs was built. - -** New user option 'switch-to-buffer-obey-display-actions'. -When non-nil, 'switch-to-buffer' uses 'pop-to-buffer-same-window' that -respects display actions specified by 'display-buffer-alist' and -'display-buffer-overriding-action'. - -** The user option 'switch-to-visible-buffer' is now obsolete. -Customize 'switch-to-prev-buffer-skip' instead. - -** New user option 'switch-to-prev-buffer-skip'. -This user option allows specifying the set of buffers that may be -shown by 'switch-to-prev-buffer' and 'switch-to-next-buffer' more -stringently than the now obsolete 'switch-to-visible-buffer'. - -** New 'flex' completion style. -An implementation of popular "flex/fuzzy/scatter" completion which -matches strings where the pattern appears as a subsequence. Put -simply, makes "foo" complete to both "barfoo" and "frodo". Add 'flex' -to 'completion-styles' or 'completion-category-overrides' to use it. - -** The 'completion-common-part' face is now visible by default. - -** New face attribute ':extend' to control face extension at EOL. -The new face attribute ':extend' controls whether to use the face for -displaying the empty space beyond end of line (EOL) till the edge of -the window. By default, this attribute is non-nil only for a small -number of faces, notably, 'region'; any other face that crosses end of -line will not affect the display of the empty space at EOL. This is -to make Emacs behave more like other GUI applications with respect to -displaying faces that cross line boundaries. - -This attribute behaves specially when theme definitions are applied: -if the theme doesn't specify an explicit value of this attribute for a -face, the value from the original face definition is inherited. -Consequently, a theme generally shouldn't specify this attribute -unless it has a good reason to do so. - -** Connection-local variables -*** Connection-local variables are applied by default like file-local -and directory-local variables. - -*** The macro 'with-connection-local-variables' has been renamed from -'with-connection-local-profiles'. No argument PROFILES needed any longer. - -** New user option 'next-error-verbose' controls when 'next-error' -outputs a message about the error locus. - -** New user option 'grep-search-path' defines the directories searched for -grep hits (this used to be controlled by 'compilation-search-path'). - -** New user option 'emacs-lisp-compilation-search-path' defines the -directories searched for byte-compiler error messages (this used to -be controlled by 'compilation-search-path'). - -** Multicolor fonts such as "Noto Color Emoji" can be displayed on -Emacs configured with Cairo drawing and linked with cairo >= 1.16.0. - -** Emacs now optionally displays a fill column indicator. -This is similar to what 'fill-column-indicator' package provides, but -much faster and compatible with 'show-trailing-whitespace'. - -Customize the buffer-local user options 'display-fill-column-indicator' -and 'display-fill-column-indicator-character' to activate the -indicator. - -The indicator is not displayed at all in minibuffer windows and -in tooltips, as it is not useful there. - -There are 2 new buffer local variables and 1 face to customize this -mode, they are described in the manual "(emacs) Display". - -** 'progress-reporter-update' now accepts an optional suffix string to display. - -** New user option 'xref-file-name-display' controls the display of -file names in xref buffers. - -** New user option 'byte-count-to-string-function'. -It is used for displaying file sizes and disk space in some cases. - -** Emacs now interprets RGB triplets like HTML, SVG, and CSS do. -The X convention previously used differed slightly, particularly for -RGB triplets with a single hexadecimal digit per component. - -** The toolbar now shows the equivalent key binding in its tooltips. - -** The File menu-bar menu was re-arranged. -Print menu items moved to submenu, and also added the new entries for tabs. - -** 'scroll-lock-mode' is now bound to the 'Scroll_Lock' key globally. -Note that this key binding will not work on MS-Windows systems if -'w32-scroll-lock-modifier' is non-nil. - -** 'global-set-key', called interactively, now no longer downcases a -key binding with an upper case letter - if you can type it, you can -bind it. - -** 'read-from-minibuffer' now works with buffer-local history variables. -The HIST argument of 'read-from-minibuffer' now works correctly with -buffer-local variables. This means that different buffers can have -their own separated input history list if desired. +--- +** 'configure' now warns about not using HarfBuzz if using Cairo. +We want to encourage people to use the most modern font features +available, and this is the Cairo graphics library + HarfBuzz for font +shaping, so 'configure' now recommends that combination. -** 'backup-by-copying-when-privileged-mismatch' applies to file gid, too. -In addition to checking the file owner uid, Emacs also checks that the -group gid is not greater than 'backup-by-copying-when-privileged-mismatch'; -if so, 'backup-by-copying-when-mismatch' will be forced on. +--- +** The ftx font backend driver has been removed. +It was declared obsolete in Emacs 27.1. - -* Editing Changes in Emacs 27.1 - -** When asked to visit a large file, Emacs now offers to visit it literally. -Previously, Emacs would only ask for confirmation before visiting -large files. Now it also offers a third alternative: to visit the -file literally, as in 'find-file-literally', which speeds up -navigation and editing of large files. - -** 'zap-to-char' now uses the history of characters you used to zap to. -'zap-to-char' uses the new 'read-char-from-minibuffer' function to allow -navigating through the history of characters that have been input. -This is mostly useful for characters that have complex input methods -where inputting the character again may involve many keystrokes. - -** 'save-some-buffers' now has a new action in the prompt: 'C-f' will -exit the command and switch to the buffer currently being asked about. - -** More commands support noncontiguous rectangular regions, namely -'upcase-dwim', 'downcase-dwim', 'capitalize-dwim', 'capitalize-region', -'upcase-initials-region', 'replace-string', 'replace-regexp', and -'delimit-columns-region'. - -** The new 'amalgamating-undo-limit' variable can be used to control -how many changes should be amalgamated when using the 'undo' command. - -** The 'newline-and-indent' command (commonly bound to 'RET' in many -modes) now takes an optional numeric argument to specify how many -times is should insert newlines (and indent). - -** New command 'make-empty-file'. - -** New variable 'x-wait-for-event-timeout'. -This controls how long Emacs will wait for updates to the graphical -state to take effect (making a frame visible, for example). - -** New user option 'electric-quote-replace-double'. -This option controls whether '"' is replaced in 'electric-quote-mode', -in addition to other quote characters. If non-nil, ASCII double-quote -characters that quote text "like this" are replaced by double -typographic quotes, “like this”, in text modes, and in comments in -non-text modes. - -** New user option 'flyspell-case-fold-duplications'. -This option controls whether Flyspell mode considers consecutive words -to be duplicates if they are not in the same case. If non-nil, the -default, words are considered to be duplicates even if their letters' -case does not match. - -** 'write-abbrev-file' now includes special properties. -'write-abbrev-file' now writes special properties like ':case-fixed' -for abbrevs that have them. - -** 'write-abbrev-file' skips empty tables. -'write-abbrev-file' now skips inserting a 'define-abbrev-table' form for -tables which do not have any non-system abbrevs to save. - -** The new functions and commands 'text-property-search-forward' and -'text-property-search-backward' have been added. These provide an -interface that's more like functions like 'search-forward'. - -** 'add-dir-local-variable' now uses dotted pair notation syntax to -write alists of variables to ".dir-locals.el". This is the same -syntax that you can see in the example of a ".dir-locals.el" file in -the node "(emacs) Directory Variables" of the user manual. - -** Network connections using 'local' can now use IPv6. -'make-network-process' now uses the correct loopback address when -asked to use ':host 'local' and ':family 'ipv6'. - -** The new function 'replace-region-contents' replaces the current -region using a given replacement-function in a non-destructive manner -(in terms of 'replace-buffer-contents'). - -** The command 'replace-buffer-contents' now has two optional -arguments mitigating performance issues when operating on huge -buffers. - -** Dragging 'C-M-mouse-1' now marks rectangular regions. - -** The command 'delete-indentation' now operates on the active region. -If the region is active, the command joins all the lines in the -region. When there's no active region, the command works on the -current and the previous or the next line, as before. - -** You can now change the font size with the mouse wheel. -Scrolling the mouse wheel with the Ctrl key pressed will now act the -same as the 'C-x C-+' and 'C-x C--' commands. +--- +** Emacs no longer supports old OpenBSD systems. +OpenBSD 5.3 and older releases are no longer supported, as they lack +proper pty support that Emacs needs. -* Changes in Specialized Modes and Packages in Emacs 27.1 - -** New HTML mode skeleton 'html-id-anchor'. -This new command (which inserts an <a id="foo">_</a> skeleton) is -bound to 'C-c C-c #'. - -** New command 'font-lock-refontify'. -This is an interactive convenience function to be used when developing -font locking for a mode. It recomputes the font locking data and then -re-fontifies the buffer. - -** Font Lock is smarter about fontifying unterminated strings and comments. -When you type a quote that starts a string, or a comment delimiter -that starts a comment, font-lock will not immediately refontify the -following characters in 'font-lock-string-face' or -'font-lock-comment-face'. Instead, it will delay the fontification -beyond the current line to give you a chance to close the string or -comment. This is controlled by the new user option -'jit-lock-antiblink-grace', which specifies the delay in seconds. The -default is 2 seconds; set to nil to get back the old behavior. - -** The 'C' command in 'tar-mode' will now preserve the timestamp of -the extracted file if the new user option 'tar-copy-preserve-time' is -non-nil. - -** 'autoconf-mode' is now used instead of 'm4-mode' for the -"acinclude.m4" / "aclocal.m4" / "acsite.m4" files. - -** On GNU/Linux, 'M-x battery' will now list all batteries, no matter -what they're named, and the 'battery-linux-sysfs-regexp' variable has -been removed. - -** The 'list-processes' command now includes port numbers in the -network connection information (in addition to the host name). - -** The 'cl' package is now officially deprecated in favor of 'cl-lib'. - -** desktop - -*** When called interactively with a prefix arg 'C-u', 'desktop-read' -now prompts the user for the directory containing the desktop file. - -** display-line-numbers-mode - -*** New faces 'line-number-major-tick' and 'line-number-minor-tick', -and user options 'display-line-numbers-major-tick' and -'display-line-numbers-minor-tick' can be used to highlight the line -numbers of lines multiple of certain numbers. - -*** New variable 'display-line-numbers-offset', when non-zero, adds -an offset to absolute line numbers. - -** winner +* Startup Changes in Emacs 28.1 -*** A new user option, 'winner-boring-buffers-regexp', has been added. +** Emacs can support 24-bit color TTY without terminfo database. +If your text-mode terminal supports 24-bit true color, but your system +lacks the terminfo database, you can instruct Emacs to support 24-bit +true color by setting 'COLORTERM=truecolor' in the environment. This is +useful on systems such as FreeBSD which ships only with "etc/termcap". -** table - -*** 'table-generate-source' now supports wiki and mediawiki. -This command can now output wiki and mediawiki format tables. - -** telnet-mode - -*** Reverting a buffer in 'telnet-mode' will restart a closed connection. - -** goto-addr - -*** A way to more conveniently specify what URI address schemes should -be ignored has been added via the 'goto-address-uri-schemes-ignored' -variable. - -** tex-mode - -*** 'latex-noindent-commands' controls indentation of certain commands. -You can use this new user option to control indentation of arguments of -\emph, \footnote, and similar commands. - -** byte compiler - -*** 'byte-compile-dynamic' is now obsolete. -This is because on the one hand it suffers from misbehavior in corner -cases that have plagued it for years, and on the other hand experience -indicates that it doesn't bring any measurable benefit. - -*** The 'g' keystroke in "*Compile-Log*" buffers has been bound to a -new command that will recompile the file previously compiled with 'M-x -byte-compile-file' and the like. - -** compile.el - -*** In 'compilation-error-regexp-alist', 'line' (and 'end-line') can -be functions. - -*** 'compilation-context-lines' can now take the value t; this is like -nil, but instead of scrolling the current line to the top of the -screen when there is no left fringe, it inserts a visible arrow before -column zero. - -*** The new 'compilation-transform-file-match-alist' user option can -be used to transform file name matches compilation output, and remove -known false positives being recognized as warnings/errors. - -** cl-lib.el - -*** 'cl-defstruct' has a new ':noinline' argument to prevent inlining -its functions. - -*** 'cl-defstruct' slots accept a ':documentation' property. - -*** 'cl-values-list' will now signal an error if its argument isn't a list. - -** doc-view.el - -*** New commands 'doc-view-presentation' and 'doc-view-fit-window-to-page'. - -*** Added support for password-protected PDF files. - -*** A new user option 'doc-view-pdftotext-program-args' has been added -to allow controlling how the conversion to text is done. - -*** The prefix key 's' was changed to 'c' for slicing commands -to avoid conflicts with 'image-mode' key 's'. The new key 'c' still -has good mnemonics of "cut", "clip", "crop". - -** Ido - -*** New user option 'ido-big-directories' to mark directories whose -names match certain regular expressions as big. Ido won't attempt to -list the contents of such directories when completing file names. + +* Changes in Emacs 28.1 -** Minibuffer +** Support for '(box . SIZE)' 'cursor-type'. +By default, 'box' cursor always has a filled box shape. But if you +specify 'cursor-type' to be '(box . SIZE)', the cursor becomes a hollow +box if the point is on an image larger than 'SIZE' pixels in any +dimension. -*** New user option 'minibuffer-beginning-of-buffer-movement'. -This option allows control of how the 'M-<' command works in -the minibuffer. If non-nil, point will move to the end of the prompt -(if point is after the end of the prompt). The default is nil, which -preserves the original behavior of 'M-<' moving to the beginning of -the prompt. +--- +*** Improved language transliteration in Malayalam input methods. +Added a new Mozhi scheme. The inapplicable ITRANS scheme is now +deprecated. Errors in the Inscript method were corrected. -*** When the minibuffer is active, echo-area messages are displayed at -the end of the minibuffer instead of hiding the minibuffer by the echo -area display. The new user option 'minibuffer-message-clear-timeout' -controls how messages displayed in this situation are removed from the -minibuffer. To revert to previous behavior, where echo-area messages -temporarily overwrote the minibuffer contents until the user typed -something, set 'set-message-function' and 'clear-message-function' to -nil. + +* Editing Changes in Emacs 28.1 -*** Minibuffer now uses 'minibuffer-message' to display error messages -at the end of the active minibuffer. To disable this, remove -'minibuffer-error-initialize' from 'minibuffer-setup-hook'. ++++ +** New command 'undo-redo'. +It undoes previous undo commands, but doesn't record itself as an +undoable command. -*** 'y-or-n-p' now uses the minibuffer to read 'y' or 'n' answer. ++++ +** 'read-number' now has its own history variable. +Additionally, the function now accepts a HIST argument which can be +used to specify a custom history variable. -*** Some commands that previously used 'read-char-choice' now read -a character using the minibuffer by 'read-char-from-minibuffer'. ++++ +** Input history for 'goto-line' is now local to every buffer. +Each buffer will keep a separate history of line numbers used with +'goto-line'. This should help making faster the process of finding +line numbers that were previously jumped to. -** map.el ++++ +** When 'suggest-key-bindings' is non-nil, the completion list of 'M-x' +shows equivalent key bindings for all commands that have them. -*** Now also understands plists. -*** Now defined via generic functions that can be extended via 'cl-defmethod'. -*** Deprecate the 'map-put' macro in favor of a new 'map-put!' function. -*** 'map-contains-key' now returns a boolean rather than the key. -*** Deprecate the 'testfn' args of 'map-elt' and 'map-contains-key'. -*** New generic function 'map-insert'. -*** The 'type' arg can be a list '(hash-table :key1 VAL1 :key2 VAL2 ...)'. +--- +** Movement commands in 'gomoku-mode' are fixed. +'gomoku-move-sw' and 'gomoku-move-ne' now work correctly, and +horizontal movements now stop at the edge of the board. -** seq.el -New convenience functions 'seq-first' and 'seq-rest' give easy access -to respectively the first and all but the first elements of sequences. +** Autosaving via 'auto-save-visited-mode' can now be inhibited by +setting the variable 'auto-save-visited-mode' buffer-locally to nil. -The new predicate function 'seq-contains-p' should be used instead of -the now obsolete 'seq-contains'. + +* Changes in Specialized Modes and Packages in Emacs 28.1 -** Follow mode -In the current follow group of windows, "ghost" cursors are no longer -displayed in the non-selected follow windows. To get the old behavior -back, customize 'follow-hide-ghost-cursors' to nil. +** Windows -** New variable 'warning-fill-column' for 'display-warning'. +*** The key prefix 'C-x 4 1' displays next command buffer in the same window. +It's bound to the command 'same-window-prefix' that requests the buffer +of the next command to be displayed in the same window. -** Windmove +*** The key prefix 'C-x 4 4' displays next command buffer in a new window. +It's bound to the command 'other-window-prefix' that requests the buffer +of the next command to be displayed in a new window. -*** 'windmove-create-window' when non-nil makes a new window. -This happens upon moving off the edge of the frame. +** Frames -*** Windmove supports directional window display and selection. -The new command 'windmove-display-default-keybindings' binds default -keys with provided modifiers (by default, Shift-Meta) to the commands -that display the next buffer in the window at the specified direction. -This is like 'windmove-default-keybindings' that binds keys to commands -that select the window in the specified direction, but additionally it -displays the buffer from the next command in that window. For example, -'S-M-right C-h i' displays the "*Info*" buffer in the right window, -creating the window if necessary. A special key can be customized to -display the buffer in the same window, for example, 'S-M-0 C-h e' -displays the "*Messages*" buffer in the same window. 'S-M-t C-h r' -displays the Emacs manual in a new tab. +*** The key prefix 'C-x 5 5' displays next command buffer in a new frame. +It's bound to the command 'other-frame-prefix' that requests the buffer +of the next command to be displayed in a new frame. -*** Windmove also supports directional window deletion. -The new command 'windmove-delete-default-keybindings' binds default -keys with provided prefix (by default, 'C-x') and modifiers (by default, -'Shift') to the commands that delete the window in the specified -direction. For example, 'C-x S-down' deletes the window below. -With a prefix arg 'C-u', also kills the buffer in that window. -With 'M-0', deletes the selected window and selects the window -that was in the specified direction. +** Tab Bars -*** New command 'windmove-swap-states-in-direction' binds default keys -to the commands that swap the states of the selected window with the -window in the specified direction. +*** The key prefix 'C-x t t' displays next command buffer in a new tab. +It's bound to the command 'other-tab-prefix' that requests the buffer +of the next command to be displayed in a new tab. -*** Windmove code no longer used is now obsolete. -That includes the user option 'windmove-window-distance-delta' and the -functions 'windmove-coord-add', 'windmove-constrain-to-range', -'windmove-constrain-around-range', 'windmove-frame-edges', -'windmove-constrain-loc-for-movement', 'windmove-wrap-loc-for-movement', -'windmove-reference-loc' and 'windmove-other-window-loc'. +*** The tab bar is frame-local when 'tab-bar-show' is a number. +Show/hide the tab bar independently for each frame, according to the +value of 'tab-bar-show'. -** Octave mode -The mode is automatically enabled in files that start with the -'function' keyword. +** New bindings in occur-mode, 'next-error-no-select' bound to 'n' and +'previous-error-no-select' bound to 'p'. -** project.el +** EIEIO -*** New commands 'project-search' and 'project-query-replace-regexp'. ++++ +*** The macro 'oref-default' can now be used with 'setf'. +It is now defined as a generalized variable that can be used with +'setf' to modify the value stored in a given class slot. -*** New user option 'project-read-file-name-function'. +** New minor mode 'cl-font-lock-built-in-mode' for 'lisp-mode'. +The mode provides refined highlighting of built-in functions, types, +and variables. -** Etags +** Archive mode -*** 'next-file' is now an obsolete alias of 'tags-next-file'. +*** Can now modify members of 'ar' archives. -*** 'tags-loop-revert-buffers' is an obsolete alias of -'fileloop-revert-buffers'. +*** Display of summaries unified between backends. -*** The 'tags-loop-continue' function along with the -'tags-loop-operate' and 'tags-loop-scan' variables are now obsolete; -use the new 'fileloop-initialize' and 'fileloop-continue' functions -instead. +*** New user option 'archive-hidden-columns' and command +'archive-hideshow-column'. These let you control which columns are +displayed and which are kept hidden. -*** etags is now able to read Zstandard-compressed files. +** Emacs Lisp mode -** bibtex +*** The mode-line now indicates whether we're using lexical or dynamic scoping. -*** New commands 'bibtex-next-entry' and 'bibtex-previous-entry'. -In 'bibtex-mode-map', 'forward-paragraph' and 'backward-paragraph' are -remapped to these, respectively. +*** A space between an open paren and a symbol changes the indentation rule. +The presence of a space between an open paren and a symbol now is +taken as a statement by the programmer that this should be indented +as a data list rather than as a piece of code. ** Dired -*** New command 'dired-create-empty-file'. - -*** New command 'dired-number-of-marked-files'. -It is by default bound to '* N'. - -*** The marking commands now report how many files were marked by the -command itself, not how many files are marked in total. - -*** The new user option 'dired-create-destination-dirs' controls whether -'dired-do-copy' and 'dired-rename-file' should create non-existent -directories in the destination. - -*** 'dired-dwim-target' can be customized to prefer either the next window, -or one of the most recently visited windows with a Dired buffer. - -*** When the new user option 'dired-vc-rename-file' is non-nil, -Dired performs file renaming using underlying version control system. - -*** Zstandard compression is now supported for 'dired-do-compress' and -'dired-do-compress-to'. - -*** On systems that support suid/guid files, Dired now fontifies the -permissions of such files with a special face 'dired-set-id'. - -*** A new face, 'dired-special', is used to highlight sockets, named -pipes, block devices and character devices. - -** Find-Dired +*** New user option 'dired-mark-region' affects all Dired commands +that mark files. When non-nil and the region is active in Transient +Mark mode, then Dired commands operate only on files in the active +region. The values 'file' and 'line' of this user option define the +details of marking the file at the end of the region. -*** New user option 'find-dired-refine-function'. -The default value is 'find-dired-sort-by-filename'. - -*** New sorting options for the user option 'find-ls-option'. +*** State changing VC operations are supported in Dired on files and +directories with the help of new command 'dired-vc-next-action'. ** Change Logs and VC -*** New user option 'vc-tor'. -When non-nil, this user option causes the VC commands to communicate -with the repository via Tor's proxy, using the 'torsocks' wrapper -script. The default is nil. - -*** New command 'log-edit-generate-changelog-from-diff', bound to 'C-c C-w'. -This generates ChangeLog entries from the VC fileset diff. - -*** Recording ChangeLog entries doesn't require an actual file. -If a ChangeLog file doesn't exist, and if the new user option -'add-log-dont-create-changelog-file' is non-nil (which is the -default), commands such as 'C-x 4 a' will add log entries to a -suitable named temporary buffer. (An existing ChangeLog file will -still be used if it exists.) Set the user option to nil to get the -previous behavior of always creating a buffer that visits a ChangeLog -file. - -*** The new 'd' command ('vc-dir-clean-files') in 'vc-dir-mode' -buffers will delete the marked files (or if no files are marked, the -file under point). This command does not notify the VC backend, and -is mostly useful for unregistered files. - -*** 'vc-dir-ignore' now takes a prefix argument to ignore all marked files. - -*** New user option 'vc-git-grep-template'. -This new user option allows customizing the default arguments passed to -'git-grep' when 'vc-git-grep' is used. - -*** Command 'vc-git-stash' now respects marks in the "*vc-dir*" buffer. -When some files are marked, only those are stashed. -When no files are marked, all modified files are stashed, as before. - -*** 'vc-dir' now shows a button allowing you to hide the stash list. -Controlled by user option 'vc-git-show-stash'. Default t means show -the entire list as before. An integer value limits the list length -(but still allows you to show the entire list via the button). - -*** 'vc-git-stash' is now bound to 'C' in the stash headers. - --- -*** Some stash keybindings are now available in the stash button. -'vc-git-stash' and 'vc-git-stash-snapshot' can now be run using 'C' -and 'S' respectively, including when there are no stashes. - -*** The new hook 'vc-retrieve-tag-hook' runs after retrieving a tag. - -*** 'vc-hg' now invokes 'smerge-mode' when visiting files. -Code that attempted to invoke 'smerge-mode' when visiting an Hg file -with conflicts existed in earlier versions of Emacs, but incorrectly -never detected a conflict due to invalid assumptions about cached -values. - -*** The Hg (Mercurial) back-end now supports 'vc-region-history'. -The 'C-x v h' command now works in buffers that visit files controlled -by Hg. - -*** The Hg (Mercurial) back-end now prompts for revision to merge when -you invoke 'C-x v m' ('vc-merge'). - -*** The Hg (Mercurial) back-end now uses tags, branches and bookmarks -instead of revision numbers as completion candidates when it prompts -for a revision. - -*** New user option 'vc-hg-revert-switches'. -It specifies switches to pass to Hg's 'revert' command. - -*** 'C-u C-x v D' ('vc-root-version-diff') prompts for two revisions -and compares their entire trees. - -*** 'C-x v M D' ('vc-diff-mergebase') and 'C-x v M L' ('vc-log-mergebase') -print diffs and logs between the merge base (common ancestor) of two -given revisions. - -*** New command 'vc-log-search' asks for a pattern, searches it -in the revision log, and displays matched log entries in the -log buffer. For example, 'M-x vc-log-search RET bug#36644 RET' -displays all entries whose log messages match the bug number. -With a prefix argument asks for a command, so for example, -'C-u M-x vc-log-search RET git log -1 f302475 RET' will display -just one log entry found by its revision number. - -*** It is now possible to display a specific revision given by its ID. -If you invoke 'C-x v L' ('vc-print-root-log') with a numeric argument -of 1, as in 'C-1 C-x v L' or 'C-u 1 C-x v L', it asks for a revision -ID, and shows its log entry together with the diffs introduced by the -revision's commit. (For some less capable VCSes, only the log entry -is shown.) - -*** New user option 'vc-find-revision-no-save'. -With non-nil, 'vc-find-revision' doesn't write the created buffer to file. - -*** 'C-x v =' can now mimic Magit's diff format. -Set the new user option 'diff-font-lock-prettify' to t for that, see -below under "Diff mode". - -*** The 'diff' function arguments OLD and NEW may each be a buffer -rather than a file, in non-interactive calls. This change was made in -Emacs 24.1, but wasn't documented until now. - -*** New command 'diff-buffers' interactively diffs two buffers. - -** Diff mode - -*** Hunks are now automatically refined by font-lock. -To disable refinement, set the new user option 'diff-refine' to nil. -To get back the old behavior where hunks are refined as you navigate -through a diff, set 'diff-refine' to the symbol 'navigate'. - -*** 'diff-auto-refine-mode' is deprecated in favor of 'diff-refine'. -It is no longer enabled by default and binding it no longer has any -effect. - -*** Better syntax highlighting of Diff hunks. -Fragments of source in Diff hunks are now by default highlighted -according to the appropriate major mode. Customize the new user -option 'diff-font-lock-syntax' to nil to disable this. - -*** File headers can be shortened, mimicking Magit's diff format. -To enable it, set the new user option 'diff-font-lock-prettify' to t. -On GUI frames, this option also displays the insertion and deletion -indicators on the left fringe. - -*** Prefix arg of 'diff-goto-source' means jump to the old revision -of the file under version control if point is on an old changed line, -or to the new revision of the file otherwise. - -** Texinfo - -*** New function for inserting '@pxref', '@xref', or '@ref' commands. -The function 'texinfo-insert-dwim-@ref', bound to 'C-c C-c r' by -default, inserts one of three types of references based on the text -surrounding point, namely '@pxref' near a parenthesis, '@xref' at the -start of a sentence or at '(point-min)', else '@ref'. - -** Browse-url - -*** The function 'browse-url-emacs' can now visit a URL in selected window. -It now treats the optional 2nd argument to mean that the URL should be -shown in the currently selected window. - -*** A new function, 'browse-url-add-buttons' can be used to add clickable -links to most ordinary special-mode buffers that display text that -have URLs embedded. 'browse-url-button-regexp' controls what's -considered a button. - -*** New user option 'browse-url-secondary-browser-function'. -It can be set to a function that invokes an alternative browser. - -** Comint - -*** 'send-invisible' is now an obsolete alias for 'comint-send-invisible'. -Also, 'shell-strip-ctrl-m' is declared obsolete. - -*** 'C-c .' ('comint-insert-previous-argument') no longer interprets '&'. -This feature caused problems when '&&' was present in the previous -command. Since this command emulates 'M-.' in Bash and zsh, neither -of which treats '&' specially, the feature was removed for -compatibility with these shells. - -*** 'comint-insert-previous-argument' can now count arguments from the end. -By default, invoking 'C-c .' with a numeric argument N would copy the -Nth argument, counting from the first one. But if the new user option -'comint-insert-previous-argument-from-end' is non-nil, it will copy -the Nth argument counting from the last one. Thus 'C-c .' can now -better emulate 'M-.' in both Bash and zsh, since the former counts -from the beginning of the arguments, while the latter counts from the -end. - -*** 'comint-run' can now accept a list of switches to pass to the program. -'C-u M-x comint-run' will prompt for the switches interactively. - -*** Abnormal hook 'comint-password-function' has been added. -This hook permits a derived mode to supply a password for the -underlying command interpreter without prompting the user. For -example, in 'sql-mode', the password for connecting to the database may -be stored in the connection wallet and may be passed on the command -line to start the SQL interpreter. This is a potential security flaw -that could expose user's database passwords on the command line -through the use of a process list (Bug#8427). With this hook, it is -possible to not pass the password on the command line and wait for the -program to prompt for the password. When it does so, the password can -be supplied to the SQL interpreter without involving the user just as -if it had been supplied on the command line. - -** SQL - -*** SQL Indent Minor Mode -SQL Mode now supports the ELPA 'sql-indent' package for assisting -sophisticated SQL indenting rules. Note, however, that SQL is not -like other programming languages like C, Java, or Python where code is -sparse and rules for formatting are fairly well established. Instead -SQL is more like COBOL (from which it came) and code tends to be very -dense and line ending decisions driven by syntax and line length -considerations to make readable code. Experienced SQL developers may -prefer to rely upon existing Emacs facilities for formatting code but -the 'sql-indent' package provides facilities to aid more casual SQL -developers layout queries and complex expressions. - -**** 'sql-use-indent-support' (default t) enables SQL indention support. -The 'sql-indent' package from ELPA must be installed to get the -indentation support in 'sql-mode' and 'sql-interactive-mode'. - -**** 'sql-mode-hook' and 'sql-interactive-mode-hook' changed. -Both hook variables have had 'sql-indent-enable' added to their -default values. If you have existing customizations to these -variables, you should make sure that the new default entry is -included. - -*** Connection Wallet -Database passwords can now by stored in NETRC or JSON data files that -may optionally be encrypted. When establishing an interactive session -with the database via 'sql-connect' or a product specific function, -like 'sql-mysql' or 'sql-postgres', the password wallet will be -searched for the password. The 'sql-product', 'sql-server', -'sql-database', and the 'sql-username' will be used to identify the -appropriate authorization. This eliminates the discouraged practice of -embedding database passwords in your Emacs initialization. - -See the 'auth-source' module for complete documentation on the file -formats. By default, the wallet file is expected to be in the -'user-emacs-directory', named "sql-wallet" or ".sql-wallet", with -".json" (JSON) or no (NETRC) suffix. Both file formats can optionally -be encrypted with GPG by adding an additional ".gpg" suffix. - -** Term - -*** 'term-read-noecho' is now obsolete, use 'read-passwd' instead. - -*** 'serial-term' now takes an optional parameter to leave the -emulator in line mode. - -** Flymake - -*** The variable 'flymake-diagnostic-types-alist' is obsolete. -You should instead set properties on known diagnostic symbols, like -':error' and ':warning', as demonstrated in the Flymake manual. - -*** New user option 'flymake-start-on-save-buffer'. -Control whether Flymake starts checking the buffer on save. - -*** Flymake and backend functions may exchange hints about buffer changes. -This enables more efficient backends. See the docstring of -'flymake-diagnostic-functions' or the Flymake manual for details. - -*** 'flymake-start-syntax-check-on-newline' is now obsolete, -use 'post-self-insert-hook' to check on newline. - -** Ruby - -*** The Rubocop Flymake diagnostic function will only run Lint cops if -it can't find the config file. - -*** Rubocop is called with 'bundle exec' if Gemfile mentions it. - -*** New command 'ruby-find-library-file' bound to 'C-c C-f'. - -** Package - -*** Warn if "footer line" is missing, but still install package. -package.el used to refuse to install a package without the so-called -"footer line", which appears at the very end of the file: - -;;; FILENAME ends here - -package.el will now install packages without this line, but it will -issue a warning. To avoid this warning, packages should keep the -"footer line". - -Note that versions of Emacs older than 27.1 will not only refuse to -install packages without such a line -- they will be unable to parse -package data. It is therefore recommended to keep this line. - -*** Change of 'package-check-signature' for packages with multiple sigs. -In previous Emacsen, t checked that all signatures are valid. -Now t only checks that at least one signature is valid and the new 'all' -value needs to be used if you want to enforce that all signatures -are valid. This only affects packages with multiple signatures. - -*** The meaning of 'allow-unsigned' in 'package-check-signature' has -changed slightly: If a usable OpenPGP configuration can't be found -(for instance, if gpg isn't installed), it now has the same meaning as -nil. - -*** New function 'package-get-version' lets packages query their own version. -Example use in auctex.el: '(defconst auctex-version (package-get-version))' - -*** New 'package-quickstart' feature. -When 'package-quickstart' is non-nil, package.el precomputes a big -autoloads file so that activation of packages can be done much faster, -which can speed up your startup significantly. -It also causes user options like 'package-user-dir' and -'package-load-list' to be consulted when 'package-quickstart-refresh' -is run rather than at startup so you don't need to set them in your -early init file. - -*** New function 'package-activate-all'. - -*** New functions for filtering packages list. -A new function has been added which allows users to filter the -packages list by name: 'package-menu-filter-by-name'. By default, it -is bound to '/ n'. Additionally, the function -'package-menu-filter-by-keyword' has been renamed from -'package-menu-filter'. Its keybinding has also been changed to '/ k' -(from 'f'). To clear any of the two filters, the user can now call -the 'package-menu-clear-filter' function, bound to '/ /' by default. - -*** Imenu support has been added to 'package-menu-mode'. - -*** The package list can now be sorted by version or description. - -*** In Package Menu, 'g' now updates package data from archives. -Previously, 'g' invoked 'tabulated-list-revert' which did not update -the cached archive data. It is now bound to 'revert-buffer', which -will update the data. +*** More VC commands can be used from non-file buffers. +The relevant commands are those that don't change the VC state. +The non-file buffers which can use VC commands are those that have +their 'default-directory' under VC. -'package-menu-refresh' is an obsolete alias for 'revert-buffer'. +*** New command 'vc-dir-root' uses the root directory without asking. -** Info +*** New commands 'vc-dir-mark-registered-files' (bound to '* r') and +'vc-dir-mark-unregistered-files'. -*** Clicking on the left/right arrow icon in the Info tool-bar while -holding down the Ctrl key pops up a menu of previously visited Info nodes -where you can select a node to go back (like in browsers). - -*** Info can now follow 'file://' protocol URLs. -The 'file://' URLs in Info documents can now be followed by passing -them to the 'browse-url' function, like the other protocols: 'ftp', -'http', and 'https'. This allows having references to local HTML -files, for example. - -** Display of man pages now limits the width for formatting pages. -The new user option 'Man-width-max' (80 by default) limits the number -of columns passed to the 'man' program for formatting man pages. This -is to enhance readability when man pages are displayed in very wide -windows (which are customary with today's large displays). - -** Xref - -*** New command 'xref-find-definitions-at-mouse'. -This command finds definitions of the identifier at the place of a -mouse click event, and is intended to be bound to a mouse event. - -*** Changing 'xref-marker-ring-length' works after xref.el is loaded. -Previously, setting 'xref-marker-ring-length' would only take effect -if set before xref.el was loaded. - -*** 'xref-find-definitions' now sets the mark at the buffer position -where it was invoked. - -*** New xref faces 'xref-file-header', 'xref-line-number', 'xref-match'. - -*** New user option 'xref-show-definitions-function'. -It encapsulates the logic pertinent to showing the result of -'xref-find-definitions'. The user can change it to customize its -behavior and the display of results. - -*** Search results show the buffer even for one hit. -The search-type Xref commands (e.g. 'xref-find-references' or -'project-find-regexp') now show the results buffer even when there is -only one hit. This can be altered by changing 'xref-show-xrefs-function'. - -*** Xref buffers support refreshing the search results. -A new command 'xref-revert-buffer' is bound to 'g'. - -*** Imenu support has been added to 'xref--xref-buffer-mode'. - -*** New generic method 'xref-backend-identifier-completion-ignore-case'. -Using it, the etags backend now honors 'tags-case-fold-search' during -identifier completion. - -** Checkdoc - -*** Checkdoc can now optionally spell-check doc strings. -Invoking 'checkdoc-buffer' with a non-nil TAKE-NOTES argument -(interactively, with a prefix arg) will now spell-check the doc -strings and report all the spelling mistakes. - -** Icomplete - -*** New minor mode Fido mode. -This mode is based on Icomplete, and its name stands for "Fake Ido". -The point of this mode is to be an 'ido-mode' workalike, providing -most of the functionality present in 'ido-mode' that is not in -Icomplete, which is much more compatible with all of Emacs's -completion facilities. - -** Ecomplete - -*** The Ecomplete sorting has changed to a decay-based algorithm. -This can be controlled by the new 'ecomplete-sort-predicate' user option. - -*** The 'ecomplete-database-file' file is now placed in -"~/.emacs.d/ecompleterc" by default. Of course it will still find it -if you have it in "~/.ecompleterc". +*** Support for bookmark.el. +Bookmark locations can refer to VC directory buffers. ** Gnus -*** 'mm-uu-diff-groups-regexp' now defaults to matching all groups, -which means that "git am" diffs are recognized everywhere. - -*** Two new Gnus summary mode navigation commands have been added, -bound to the '[' and ']' keys: 'gnus-summary-prev-unseen-article' and -'gnus-summary-next-unseen-article'. These take you (respectively) to -the previous unseen or next unseen article. (These are the ones that -are marked with "." in the summary mode lines.) - -*** The Gnus user variable 'nnimap-expunge' supports three new values: -'never' for never expunging messages, 'immediately' for immediately -expunging deleted messages, and 'on-exit' to expunge deleted articles -when exiting the group's summary buffer. Setting 'nnimap-expunge' to -nil or t is still supported but not recommended, since it may -result in Gnus expunging all messages that have been flagged as -deleted by any IMAP client (rather than just those that have been -deleted by Gnus). - -*** New user option 'gnus-use-atomic-windows' makes Gnus window layouts atomic. -See the "(elisp) Atomic Windows" node of the Elisp manual for details. - -*** There's a new value for 'gnus-article-date-headers', -'combined-local-lapsed', which will show both the time (in the local -timezone) and the lapsed time. - -*** Gnus now maps imaps to 993 only on old MS-Windows versions. -The nnimap backend used to do this unconditionally to work around -problems on old versions of MS-Windows. This is now done only for -Windows XP and older. - -*** The nnimap backend now has support for IMAP namespaces. -This feature can be enabled by setting the new 'nnimap-use-namespaces' -server variable to non-nil. - -*** A prefix argument to 'gnus-summary-limit-to-score' will limit in reverse. -Limit to articles with score "at or below" the SCORE argument rather -than "at or above". - -*** The function 'gnus-score-find-favorite-words' has been renamed -from 'gnus-score-find-favourite-words'. - -*** Gmane has been removed as an nnir backend, since Gmane no longer -has a search engine. - -*** Splitting mail on common mailing list headers has been added. -See the concept index in the Gnus manual for the 'match-list' entry. - -*** nil is no longer an allowed value for 'mm-text-html-renderer'. - -*** The default value of 'mm-inline-large-images' has changed from nil -to 'resize', which means that large images will be resized instead of -displayed with an external program by default. - -*** A new Gnus summary mode command, 'S A' ('gnus-summary-attach-article') -can be used to attach the current article(s) to a pre-existing Message -buffer, or create a new Message buffer with the article(s) attached. - -*** A new Gnus summary mode command, 'w' ('gnus-summary-browse-url') -scans the article buffer for URLs, and offers them to the user to open -with 'browse-url'. - -*** New user option 'nnir-notmuch-filter-group-names-function'. -This option controls whether and how to use Gnus search groups as -'path:' search terms to 'notmuch'. - -*** The buttons in the Gnus article buffer were formerly widgets -(i.e., buttons from widget.el). This has now changed, and they are -now buttons (from button.el), and commands like 'TAB' now search for -buttons instead of widgets. There should be no user-visible changes, -but out-of-tree code that relied on widgets being present might now -fail. - -** erc - -*** New hook 'erc-insert-done-hook'. -This hook is called after strings have been inserted into the buffer, -and is free to alter point and window configurations, as it's not -called from inside a 'save-excursion', as opposed to 'erc-insert-post-hook'. - -*** 'erc-button-google-url' has been renamed to 'erc-button-search-url' -and its value has been changed to Duck Duck Go. - -*** 'erc-send-pre-hook' and 'erc-send-this' have been obsoleted. -The user option to use instead to alter text to be sent is now -'erc-pre-send-functions'. - -*** Improve matching/highlighting of nicknames. -Open and close parenthesis and apostrophe are not considered valid -nick characters anymore, matching the given grammar in RFC 2812 -section 2.3.1. This enables correct matching and highlighting of -nicks when they are surrounded by parentheses, like "(nick)", and when -adjacent to an apostrophe, like "nick's". - -*** Set 'erc-button-url-regexp' to 'browse-url-button-regexp' -which better handles surrounding pair of parentheses. - -*** New function 'erc-switch-to-buffer-other-window' -which is like 'erc-switch-to-buffer', but opens the buffer in another -window. - -*** New function 'erc-track-switch-buffer-other-window' -which is like 'erc-track-switch-buffer', but opens the buffer in -another window. - -** EUDC - -*** XEmacs support has been removed. - -** eww/shr - -*** The new user option 'shr-cookie-policy' can be used to control -when to use cookies when fetching embedded images. The default is to -use them when the images are from the same domain as the main HTML -document. - -*** The 'eww' command can now create a new EWW buffer. -Invoking the command with a prefix argument will cause it to create a -new EWW buffer for the URL instead of reusing the default one. - -*** Clicking with the Ctrl key or 'C-u RET' on a link opens a new tab -when tab-bar-mode is enabled. - -*** The 'd' ('eww-download') command now falls back to current page's URL. -If this command is invoked with no URL at point, it now downloads the -current page instead of signaling an error. - -*** When opening external links in eww/shr (typically with the -'C-u RET' keystroke on a link), the link will be flashed with the new -'shr-selected-link' face to give the user feedback that the command -has been executed. - -*** New user option 'shr-discard-aria-hidden'. -If set, shr will not render tags with attribute 'aria-hidden="true"'. -This attribute is meant to tell screen readers to ignore a tag. - -*** 'shr-external-browser' has been made into an obsolete alias -of 'browse-url-secondary-browser-function'. - -*** 'shr-tag-ol' now respects the ordered list 'start' attribute. - -*** The following tags are now handled: '<code>', '<abbr>', and '<acronym>'. - -** Htmlfontify - -*** The functions 'hfy-color', 'hfy-color-vals' and -'hfy-fallback-color-values' and the variables 'hfy-fallback-color-map' -and 'hfy-rgb-txt-color-map' have been renamed from names that used -'colour' instead of 'color'. - -** Enriched mode supports the 'charset' text property. -You can add or modify the 'charset' text properties of text using the -'Edit->Text Properties->Special Properties' menu, or by invoking the -'facemenu-set-charset' command. Documents in Enriched mode will be -saved with the charset properties, and those properties will be -restored when the file is visited. - -** Smtpmail - -*** Authentication mechanisms can be added via external packages, by -defining new 'cl-defmethod' of 'smtpmail-try-auth-method'. - -*** To always force smtpmail to send credentials over on the first -attempt when communicating with the SMTP server(s), the -'smtpmail-servers-requiring-authorization' user option can be used. - -*** smtpmail will now try resending mail when getting a transient "4xx" -error message from the SMTP server. The new 'smtpmail-retries' -user option says how many times to retry. - -** Footnote mode - -*** Support Hebrew-style footnotes. - -*** Footnote text lines are now aligned. -Can be controlled via the new user option 'footnote-align-to-fn-text'. - -** CSS mode - -*** A new command 'css-cycle-color-format' for cycling between color -formats (e.g. "black" => "#000000" => "rgb(0, 0, 0)") has been added, -bound to 'C-c C-f'. - -*** CSS mode, SCSS mode, and Less CSS mode now have support for Imenu. - -** SGML mode - -*** 'sgml-quote' now handles double quotes and apostrophes -when escaping text and in addition all numeric entities when -unescaping text. - -** Python mode - -*** Python mode supports three different font lock decoration levels. -The maximum level is used by default; customize -'font-lock-maximum-decoration' to tone down the decoration. ++++ +*** The name of dependent Gnus sessions has changed from "slave" to "child". +The names of the commands 'gnus-slave', 'gnus-slave-no-server' and +'gnus-slave-unplugged' have changed to 'gnus-child', +'gnus-child-no-server' and 'gnus-child-unplugged' respectively. -*** New user option 'python-pdbtrack-kill-buffers'. -If non-nil, the default, buffers opened during pdbtracking session are -killed when pdbtracking session is finished. ++++ +*** The 'W Q' summary mode command now takes a numerical prefix to +allow adjusting the fill width. -*** New function 'python-shell-send-statement. -It sends the statement delimited by 'python-nav-beginning-of-statement' -and 'python-nav-end-of-statement' to the inferior Python process. +--- +*** Change to default value of 'message-draft-headers' user option. +The 'Date' symbol has been removed from the default value, meaning that +draft or delayed messages will get a date reflecting when the message +was sent. To restore the original behavior of dating a message +from when it is first saved or delayed, add the symbol 'Date' back to +this user option. ** Help -*** Descriptions of variables and functions give an estimated first release -where the variable or function appeared in Emacs. - -*** Output format of 'C-h l' ('view-lossage') has changed. -For convenience, 'view-lossage' now displays the last keystrokes -and commands in the same format as the edit buffer of -'edit-last-kbd-macro'. This makes it possible to copy the lines from -the buffer generated by 'view-lossage' to the "*Edit Macro*" buffer -created by 'edit-last-kbd-macro', and to save the macro by 'C-c C-c'. - -*** The list of help commands produced by 'C-h C-h' ('help-for-help') -can now be searched via 'C-s'. - -** Ibuffer - -*** New filter 'ibuffer-filter-by-process'; bound to '/ E'. - -*** All mode filters can now accept a list of symbols. -This means you can now easily filter several major modes, as well -as a single mode. - -** Search and Replace - -*** Isearch supports a prefix argument for 'C-s' ('isearch-repeat-forward') -and 'C-r' ('isearch-repeat-backward'). With a prefix argument, these -commands repeat the search for the specified occurrence of the search string. -A negative argument repeats the search in the opposite direction. -This makes possible also to use a prefix argument for 'M-s .' -('isearch-forward-symbol-at-point') to find the next Nth symbol. -Also a prefix argument is supported for 'isearch-yank-until-char', -'isearch-yank-word-or-char', 'isearch-yank-symbol-or-char'. - -*** To go to the first/last occurrence of the current search string -is possible now with new commands 'isearch-beginning-of-buffer' and -'isearch-end-of-buffer' bound to 'M-s M-<' and 'M-s M->' in Isearch. -With a numeric argument, they go to the Nth absolute occurrence -counting from the beginning/end of the buffer. This complements -'C-s'/'C-r' that searches for the next Nth relative occurrence -with a numeric argument. - -*** 'isearch-lazy-count' shows the current match number and total number -of matches in the Isearch prompt. User options -'lazy-count-prefix-format' and 'lazy-count-suffix-format' define the -format of the current and the total number of matches in the prompt's -prefix and suffix, respectively. - -*** 'lazy-highlight-buffer' highlights matches in the full buffer. -It is useful in combination with 'lazy-highlight-cleanup' customized to nil -to leave matches highlighted in the whole buffer after exiting isearch. -Also when 'lazy-highlight-buffer' prepares highlighting in the buffer, -navigation through the matches without flickering is more smooth. -'lazy-highlight-buffer-max-at-a-time' controls the number of matches to -highlight in one iteration while processing the full buffer. - -*** New isearch bindings. -'C-M-z' invokes new function 'isearch-yank-until-char', which yanks -everything from point up to but not including the specified -character into the search string. This is especially useful for -keyboard macros. - -'C-M-w' in isearch changed from 'isearch-del-char' to the new function -'isearch-yank-symbol-or-char'. 'isearch-del-char' is now bound to -'C-M-d'. - -'M-s h l' invokes 'highlight-lines-matching-regexp' using the search -string to highlight lines matching the search string. This is similar -to the existing binding 'M-s h r' ('highlight-regexp') that highlights -JUST the search string. - -*** New user option 'isearch-yank-on-move' provides options t and 'shift' -to extend the search string by yanking text that ends at the new -position after moving point in the current buffer. 'shift' extends -the search string by motion commands while holding down the shift key. - -*** 'isearch-allow-scroll' provides a new option 'unlimited' to allow -scrolling any distance off screen. - -*** Isearch now remembers the regexp-based search mode for words/symbols -and case-sensitivity together with search strings in the search ring. - -*** Isearch now has its own tool-bar and menu-bar menu. - -*** 'flush-lines' prints and returns the number of deleted matching lines. - -*** 'char-fold-to-regexp' now matches more variants of a base character. -The table used to check for equivalence of characters is now built -using the complete chain of unicode decompositions of a character, -rather than stopping after one level, such that searching for -e.g. "GREEK SMALL LETTER IOTA" will now also find "GREEK SMALL LETTER -IOTA WITH OXIA". - -*** New char-folding options: 'char-fold-include' lets you add ad hoc -foldings, 'char-fold-exclude' to remove foldings from default decomposition, -and 'char-fold-symmetric' to search for any of an equivalence class of -characters. For example, with a nil value of 'char-fold-symmetric' -you can search for "e" to find "é", but not vice versa. With a non-nil -value you can search for either, for example, you can search for "é" -to find "e". - -** Debugger - -*** The Lisp Debugger is now based on 'backtrace-mode'. -Backtrace mode adds fontification and commands for changing the -appearance of backtrace frames. See the node "(elisp) Backtraces" in -the Elisp manual for documentation of the new mode and its commands. - -** Edebug - -*** 'edebug-eval-last-sexp' and 'edebug-eval-print-last-sexp' interactively -now take a zero prefix analogously to the non-Edebug counterparts. - -*** New faces 'edebug-enabled-breakpoint' and 'edebug-disabled-breakpoint'. -When setting breakpoints in Edebug, an overlay with these faces are -placed over the point in question, depending on whether they are -enabled or not. - -*** New command 'edebug-toggle-disable-breakpoint'. -This command allows you to disable a breakpoint temporarily. This is -mainly useful with breakpoints that are conditional and would take -some time to recreate. - -*** New command 'edebug-unset-breakpoints'. -To clear all breakpoints in the current form, the 'U' command in -'edebug-mode', or 'M-x edebug-unset-breakpoints' can be used. - -*** Re-instrumenting a function with Edebug will now try to preserve -previously-set breakpoints. However, if the code has changed -substantially, this may not be possible. - -*** New command 'edebug-remove-instrumentation'. -This command removes Edebug instrumentation from all functions that -have been instrumented. - -*** The runtime behavior of Edebug's instrumentation can be changed -using the new variables 'edebug-behavior-alist', -'edebug-after-instrumentation-function' and -'edebug-new-definition-function'. Edebug's behavior can be changed -globally or for individual definitions. - -*** Edebug's backtrace buffer now uses 'backtrace-mode'. -Backtrace mode adds fontification, links and commands for changing the -appearance of backtrace frames. See the node "(elisp) Backtraces" in -the Elisp manual for documentation of the new mode and its commands. - -The binding of 'd' in Edebug's keymap is now 'edebug-pop-to-backtrace' -which replaces 'edebug-backtrace'. Consequently Edebug's backtrace -windows now behave like those of the Lisp Debugger and of ERT, in that -when they appear they will be the selected window. - -The new 'backtrace-goto-source' command, bound to 's', works in -Edebug's backtraces on backtrace frames whose source code has -been instrumented by Edebug. - -** Enhanced xterm support - -*** New user option 'xterm-set-window-title' controls whether Emacs sets -the XTerm window title. This feature is experimental and is disabled -by default. - -** Grep - -*** 'rgrep', 'lgrep' and 'zrgrep' now hide part of the command line -that contains a list of ignored directories and files. -Clicking on the button with ellipsis unhides it. -The abbreviation can be disabled by the new user option -'grep-find-abbreviate'. The new command -'grep-find-toggle-abbreviation' toggles it interactively. - -*** 'grep-find-use-xargs' is now customizable with sorting options. - -** ERT - -*** New variable 'ert-quiet' allows making ERT output in batch mode -less verbose by removing non-essential information. - -*** ERT's backtrace buffer now uses 'backtrace-mode'. -Backtrace mode adds fontification and commands for changing the -appearance of backtrace frames. See the node "(elisp) Backtraces" in -the Elisp manual for documentation of the new mode and its commands. - -** Gamegrid - -*** Gamegrid now determines its default glyph size based on display -dimensions, instead of always using 16 pixels. As a result, Tetris, -Snake and Pong are better playable on HiDPI displays. - -*** 'gamegrid-add-score' can now sort scores from lower to higher. -This is useful for games where lower scores are better, like time-based games. - -** Filecache ++++ +*** New command 'describe-keymap' describes keybindings in a keymap. -*** Completing file names in the minibuffer via 'C-TAB' now uses the -styles as configured by the user option 'completion-styles'. +--- +*** The command 'view-lossage' can now be invoked from the menu bar. +The menu-bar Help menu now has a "Show Recent Inputs" item under the +"Describe" sub-menu. -** New macros 'thunk-let' and 'thunk-let*'. -These macros are analogue to 'let' and 'let*', but create bindings that -are evaluated lazily. +--- +** The old non-SMIE indentation of 'sh-mode' has been removed. -** next-error +--- +** The sb-image.el library is now marked obsolete. +This file was a compatibility kludge which is no longer needed. -*** New user option 'next-error-find-buffer-function'. -The value should be a function that determines how to find the -next buffer to be used by 'next-error' and 'previous-error'. The -default is to use the last buffer that navigated to the current -error. +--- +** Lisp mode now uses 'common-lisp-indent-function'. +To revert to the previous behaviour, +'(setq lisp-indent-function 'lisp-indent-function)' from 'lisp-mode-hook'. -*** New command 'next-error-select-buffer'. -It can be used to set any buffer as the next one to be used by -'next-error' and 'previous-error'. +** Edebug -** nxml-mode ++++ +*** Edebug specification lists can use the new keyword '&error', which +unconditionally aborts the current edebug instrumentation with the +supplied error message. -*** The default value of 'nxml-sexp-element-flag' is now t. -This means that pressing 'C-M-SPACE' now selects the entire tree by -default, and not just the opening element. ++++ +** ElDoc + +*** New hook 'eldoc-documentation-functions'. +This hook is intended to be used for registering doc string functions. +These functions don't need to produce the doc string right away, they +may arrange for it to be produced asynchronously. The results of all +doc string functions are accessible to the user through the user +option 'eldoc-documentation-strategy'. + +*** New user option 'eldoc-documentation-strategy'. +The built-in choices available for this user option let users compose +the results of 'eldoc-documentation-functions' in various ways, even +if some of those functions are sychronous and some asynchchronous. +The user option replaces 'eldoc-documentation-function', which is now +obsolete. + +*** 'eldoc-echo-area-use-multiline-p' is now handled by ElDoc. +The user option 'eldoc-echo-area-use-multiline-p' is now handled +by the ElDoc library itself. Functions in +'eldoc-documentation-functions' don't need to worry about consulting +it when producing a doc string. ** Eshell -*** TAB completion uses the standard 'completion-at-point' rather than -'pcomplete'. Its UI is slightly different but can be customized to -behave similarly, e.g. Pcomplete's default cycling can be obtained -with '(setq completion-cycle-threshold 5)'. - -*** Expansion of history event designators is disabled by default. -To restore the old behavior, use - - (add-hook 'eshell-expand-input-functions - #'eshell-expand-history-references) - -*** The function 'eshell-uniquify-list' has been renamed from -'eshell-uniqify-list'. - -*** The function 'eshell/kill' is now able to handle signal switches. -Previously 'eshell/kill' would fail if provided a kill signal to send -to the process. It now accepts signals specified either by name or by -its number. - -*** Emacs now follows symlinks in history-related files. -The files specified by 'eshell-history-file-name' and -'eshell-last-dir-ring-file-name' can include symlinks; these are now -followed when Emacs writes the relevant history variables to the disk. - -** Shell - -*** Program name completion inside remote shells works now as expected. - -*** The user option 'shell-file-name' can be set now as connection-local -variable for remote shells. It still defaults to "/bin/sh". - -** Single shell commands - -*** New values of 'shell-command-dont-erase-buffer'. -This user option can now have the value 'erase' to force to erase the -output buffer before execution of the command, even if the output goes -to the current buffer. Additional values 'beg-last-out', -'end-last-out', and 'save-point' control where to put point in the -output buffer after inserting the 'shell-command' output. - -*** The new functions 'shell-command-save-pos-or-erase' and -'shell-command-set-point-after-cmd' control how point is handled -between two consecutive shell commands in the same output buffer. - -*** 'async-shell-command-width' defines the number of display columns -available for output of asynchronous shell commands. - -*** Prompt for shell commands can now show the current directory. -Customize the new user option 'shell-command-prompt-show-cwd' to enable it. - -** Pcomplete - -*** The 'pcomplete' command is now obsolete. -The Pcomplete functionality can be obtained via 'completion-at-point' -instead, by adding 'pcomplete-completions-at-point' to -'completion-at-point-functions'. - -*** The function 'pcomplete-uniquify-list' has been renamed from -'pcomplete-uniqify-list'. - -*** 'pcomplete/make' now completes on targets in included files, recursively. -To recover the previous behavior, set new user option -'pcmpl-gnu-makefile-includes' to nil. +--- +*** Environment variable 'INSIDE_EMACS' is now copied to subprocesses. +Its value equals the result of evaluating '(format "%s,eshell" emacs-version)'. -** Auth-source +--- +*** Eshell no longer re-initializes its keymap every call. +This allows users to use (define-key eshell-mode-map ...) as usual. +Some modules have their own minor mode now to account for these +changes. -*** The Secret Service backend supports the ':create' key now. +** EUDC -*** ".authinfo" and ".netrc" files now use a new mode: 'authinfo-mode'. -This is just like 'fundamental-mode', except that it hides passwords -under a "****" display property. When the cursor moves to this text, -the real password is revealed (via 'reveal-mode'). The new -'authinfo-hidden' user option can be used to control what to hide. ++++ +*** New macOS Contacts backend. +This backend works on newer versions of macOS and is generally +preferred over the eudcb-mab.el backend. ** Tramp -*** New connection method "nextcloud", which allows accessing OwnCloud -or NextCloud hosted files and directories. - -*** New connection method "rclone", which allows accessing system -storages via the 'rclone' program. This feature is experimental. - -*** New connection method "sudoedit", which allows editing local files -with different user credentials. Contrary to the "sudo" method, no -session is run permanently in the background. This is for security -reasons. - -*** Connection methods "obex" and "synce" have been removed, because they -are obsoleted in GVFS. - -*** Validated passwords are saved by auth-source backends which support this. - -*** During user and host name completion in the minibuffer, results -from auth-source search are taken into account. This can be disabled -by setting the user option 'tramp-completion-use-auth-sources' to nil. - -*** The user option 'tramp-ignored-file-name-regexp' allows disabling -Tramp for some look-alike remote file names. - -*** For some connection methods, like "su" or "sudo", the host name in -multi-hop file names must match the previous hop. Default host names -are adjusted to the host name from the previous hop. - -*** A timeout has been added for the connection methods "sudo" and "doas". -The underlying session is disabled when the timeout expires. This is -for security reasons. - -*** For some connection methods, like "sshx" or "plink", it is -possible to configure the remote login shell. This avoids problems -with remote hosts, where "/bin/sh" is a link to a shell which -cooperates badly with Tramp. - -*** New commands 'tramp-rename-files' and 'tramp-rename-these-files'. -They allow saving remote files somewhere else when the corresponding -host is not reachable anymore. ++++ +*** New connection method "media", which allows accessing media devices +like cell phones, tablets or cameras. -** Rcirc ++++ +*** New command 'tramp-crypt-add-directory'. +This command marks a remote directory to contain only encrypted files. +See the "(tramp) Keeping files encrypted" node of the Tramp manual for +details. This feature is experimental. -*** New user option 'rcirc-url-max-length'. -Setting this option to an integer causes URLs displayed in Rcirc -buffers to be truncated to that many characters. +** Tempo -*** The default '/quit' and '/part' reasons are now configurable. -Two new user options are provided for this: -'rcirc-default-part-reason' and 'rcirc-default-quit-reason'. +--- +*** 'tempo-define-template' can now re-assign templates to tags. +Previously, assigning a new template to an already defined tag had no +effect. -** Register +** map.el -*** The return value of method 'register-val-describe' includes the -names of buffers shown by the windows of a window configuration. +*** Pcase 'map' pattern added keyword symbols abbreviation. +A pattern like '(map :sym)' binds the map's value for ':sym' to 'sym', +equivalent to '(map (:sym sym))'. -** Message +** Package -*** Completion of email addresses can use the standard completion UI. -This is controlled by 'message-expand-name-standard-ui'. -With the standard UI the different sources (ecomplete, bbdb, and eudc) -are matched together and try to obey 'completion-styles'. -It should work for other completion front ends like Company. ++++ +*** New functions to filter the package list. +The filter command key bindings are as follows: + +key binding +--- ------- +/ a package-menu-filter-by-archive +/ k package-menu-filter-by-keyword +/ n package-menu-filter-by-name +/ s package-menu-filter-by-status +/ v package-menu-filter-by-version +/ m package-menu-filter-marked +/ / package-menu-filter-clear -*** 'message-mode' now supports highlighting citations of different depths. -This can be customized via the new user option -'message-cite-level-function' and the new 'message-cited-text-*' faces. +--- ++++ Column widths in 'list-packages' display can now be customized. +See the new user options 'package-name-column-width', +'package-version-column-width', 'package-status-column-width', and +'package-archive-column-width'. -*** Messages can now be systematically encrypted -when the PGP keyring contains a public key for every recipient. To -achieve this, add 'message-sign-encrypt-if-all-keys-available' to -'message-send-hook'. +** gdb-mi -*** When replying a message that have addresses on the form -'"foo@bar.com" <foo@bar.com>', Message will elide the repeated "name" -from the address field in the response. ++++ +*** gdb-mi can now store and restore window configurations. +Use 'gdb-save-window-configuration' to save window configuration to a +file and 'gdb-load-window-configuration' to load from a file. These +commands can also be accessed through the menu bar under 'Gud -- +GDB-Windows'. 'gdb-default-window-configuration-file', when non-nil, +is loaded when GDB starts up. -*** The default of 'message-forward-as-mime' has changed from t to nil -as it has been reported that many recipients can't read forwards that -are formatted as MIME digests. ++++ +*** gdb-mi can now restore window configuration after quit. +Set 'gdb-restore-window-configuration-after-quit' to non-nil and Emacs +will remember the window configuration before GDB started and restore +it after GDB quits. A toggle button is also provided under 'Gud -- +GDB-Windows'. -*** 'message-forward-included-headers' has changed its default to -exclude most headers when forwarding. ++++ +*** gdb-mi now has a better logic for displaying source buffers. +Now GDB only uses one source window to display source file by default. +Customize 'gdb-max-source-window-count' to use more than one window. +Control source file display by 'gdb-display-source-buffer-action'. -*** 'mml-secure-openpgp-sign-with-sender' sets also "gpg --sender". -When 'mml-secure-openpgp-sign-with-sender' is non-nil, message sender's -email address (in addition to its old behavior) will also be used to -set gpg's "--sender email@domain" option. +** Gravatar -The option is useful for two reasons when verifying the signature: +--- +*** New user option 'gravatar-service' for host to query for gravatars. +Defaults to 'libravatar', with 'unicornify' and 'gravatar' as options. - 1. GnuPG's TOFU statistics are updated for the specific user id - (email) only. See gpg(1) man page about "--sender". +** Compilation mode - 2. GnuPG's "--auto-key-retrieve" functionality can use WKD (web key - directory) method for finding the signer's key. You need GnuPG - 2.2.17 to fully benefit from this feature. See gpg(1) man page for - "--auto-key-retrieve". +*** Regexp matching of messages is now case-sensitive by default. +The variable 'compilation-error-case-fold-search' can be set for +case-insensitive matching of messages when the old behaviour is +required, but the recommended solution is to use a correctly matching +regexp instead. -*** The 'mail-from-style' variable is now obsolete. -According to RFC 5322, only the 'angles' value is valid. +** Hi Lock mode -** EasyPG +--- +*** Matching in 'hi-lock-mode' is case-sensitive when regexp contains +upper case characters and 'search-upper-case' is non-nil. +'highlight-phrase' also uses 'search-whitespace-regexp' +to substitute spaces in regexp search. -*** 'epa-pinentry-mode' is renamed to 'epg-pinentry-mode'. -It now applies to epg functions as well as epa functions. +--- +*** The default value of 'hi-lock-highlight-range' was enlarged. +The new default value is 2000000 (2 megabytes). -*** The alias functions 'epa--encode-coding-string', -'epa--decode-coding-string', and 'epa--select-safe-coding-system' have -been removed. Use 'encode-coding-string', 'decode-coding-string', and -'select-safe-coding-system' instead. +** Texinfo -*** 'epg-context' structure supports now 'sender' slot. -The value of the new 'sender' slot (if a string) is used to set gpg's -"--sender" option. This feature is used by -'mml-secure-openpgp-sign-with-sender'. See gpg(1) manual page about -"--sender" for more information. +--- +*** New user option 'texinfo-texi2dvi-options'. +This is used when invoking 'texi2dvi' from 'texinfo-tex-buffer'. ** Rmail -*** New user option 'rmail-output-reset-deleted-flag'. -If this option is non-nil, messages appended to an output file by the -'rmail-output' command have their Deleted flag reset. - -*** The command 'rmail-summary-by-senders' with an empty argument -selects the messages to summarize with a regexp that matches the -sender of the current message. - -** Threads - -*** New variable 'main-thread' holds Emacs's main thread. -This is handy in Lisp programs that run on a non-main thread and want -to signal the main thread, e.g., when they encounter an error. - -*** 'thread-join' now returns the result of the finished thread. - -*** 'thread-signal' does not propagate errors to the main thread. -Instead, error messages are just printed in the main thread. - -*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead. - -*** New command 'list-threads' shows Lisp threads. -See the current list of live threads in a tabulated-list buffer which -automatically updates. In the buffer, you can use 's q' or 's e' to -signal a thread with quit or error respectively, or get a snapshot -backtrace with 'b'. - -** thingatpt.el - -*** 'thing-at-point' supports a new "thing" called 'uuid'. -A symbol 'uuid' can be passed to 'thing-at-point' and it returns the -UUID at point. - -*** 'number-at-point' will now recognize hex numbers like 0xAb09 and #xAb09 -and return them as numbers. - -*** 'word-at-point' and 'sentence-at-point' accept NO-PROPERTIES. -Just like 'thing-at-point' itself. - -** Interactive automatic highlighting - -*** 'highlight-regexp' can now highlight subexpressions. -The new command accepts a prefix numeric argument to choose the -subexpression. - -** Mouse display of minor mode menu - -*** 'minor-mode-menu-from-indicator' now displays full minor mode name. -When there is no menu for a mode, display the mode name after the -indicator instead of just the indicator (which is sometimes cryptic). - -** rx - -*** rx now handles raw bytes in character alternatives correctly, -when given in a string. Previously, '(any "\x80-\xff")' would match -characters U+0080...U+00FF. Now the expression matches raw bytes in -the 128...255 range, as expected. - -*** The rx 'or' and 'seq' forms no longer require any arguments. -'(or)' produces a regexp that never matches anything, while '(seq)' -matches the empty string, each being an identity for the operation. -This also works for their aliases: '|' for 'or'; ':', 'and' and -'sequence' for 'seq'. -The symbol 'unmatchable' can be used as an alternative to '(or)'. - -*** 'regexp' and new 'literal' accept arbitrary lisp as arguments. -In this case, 'rx' will generate code which produces a regexp string -at run time, instead of a constant string. - -*** New rx extension mechanism: 'rx-define', 'rx-let', 'rx-let-eval'. -These macros add new forms to the rx notation. - -*** 'anychar' is now an alias for 'anything'. -Both match any single character; 'anychar' is more descriptive. - -*** New 'intersection' form for character sets. -With 'or' and 'not', it can be used to compose character-matching -expressions from simpler parts. - -*** 'not' now accepts more argument types. -The argument can now also be a character, a single-character string, -an 'intersection' form, or an 'or' form whose arguments each match a -single character. - -*** Nested 'or' forms of strings guarantee a longest match. -For example, '(or (or "IN" "OUT") (or "INPUT" "OUTPUT"))' now matches -the whole string "INPUT" if present, not just "IN". Previously, this -was only guaranteed inside a single 'or' form of string literals. - -** Frames - -*** New command 'make-frame-on-monitor' makes a frame on the specified monitor. - -*** New value of 'minibuffer' frame parameter 'child-frame'. -This allows creating and immediately parenting a minibuffer-only child -frame when making a frame. - -*** New predicates 'display-blink-cursor-p' and 'display-symbol-keys-p'. -These predicates are to be preferred over 'display-graphic-p' when -testing for blinking cursor capability and the capability to have -symbols (e.g., '[return]', '[tab]', '[backspace]') as keys respectively. - -** Tabulated List mode - -*** New user options for tabulated list sort indicators. -You can now customize which sorting indicator character to display -near the current column in Tabulated Lists (see user options -'tabulated-list-gui-sort-indicator-asc', -'tabulated-list-gui-sort-indicator-desc', -'tabulated-list-tty-sort-indicator-asc', and -'tabulated-list-tty-sort-indicator-desc'). - -*** Two new commands and keystrokes have been added to the tabulated -list mode: 'w' (which widens the current column) and 'c' which makes -the current column contract. - -*** New function 'tabulated-list-clear-all-tags'. -This function clears all tags from the padding area in the current -buffer. Tags are typically added by calling 'tabulated-list-put-tag'. - -** Text mode - -*** 'text-mode-variant' is now obsolete, use 'derived-mode-p' instead. +--- +*** New user option 'rmail-re-abbrevs'. +Its default value matches localized abbreviations of the "reply" +prefix on the Subject line in various languages. -** CUA mode +** Apropos -*** New user option 'cua-rectangle-terminal-modifier-key'. -This user option allows for the customization of the modifier key used -in a terminal frame. +*** New commands 'apropos-next-symbol' and 'apropos-previous-symbol'. +These new navigation commands are bound to 'n' and 'p' in +'apropos-mode'. -** JS mode +** CC Mode -*** JSX syntax is now automatically detected and enabled. -If a file imports Facebook's 'React' library, or if the file uses the -extension ".jsx", then various features supporting XML-like syntax -will be supported in 'js-mode' and derivative modes. ('js-jsx-mode' -no longer needs to be enabled.) +*** Added support for Doxygen documentation style. +'doxygen' is now a valid 'c-doc-comment-style' which recognises all +comment styles supported by Doxygen (namely '///', '//!', '/** … */' +and '/*! … */'. 'gtkdoc' remains the default for C and C++ modes; to +use 'doxygen' by default one might evaluate: + + (setq-default c-doc-comment-style + '((java-mode . javadoc) + (pike-mode . autodoc) + (c-mode . doxygen) + (c++-mode . doxygen))) + +or use it in a custom 'c-style'. + +*** Added support to line up '?' and ':' of a ternary operator. +The new 'c-lineup-ternary-bodies' function can be used as a lineup +function to align question mark and colon which are part of a ternary +operator ('?:'). For example: + + return arg % 2 == 0 ? arg / 2 + : (3 * arg + 1); + +To enable, add it to appropriate entries in 'c-offsets-alist', e.g.: + + (c-set-offset 'arglist-cont '(c-lineup-ternary-bodies + c-lineup-gcc-asm-reg)) + (c-set-offset 'arglist-cont-nonempty '(c-lineup-ternary-bodies + c-lineup-gcc-asm-reg + c-lineup-arglist)) + (c-set-offset 'statement-cont '(c-lineup-ternary-bodies +)) + +** browse-url + +*** Added support for custom URL handlers. +There is a new variable 'browse-url-default-handlers' and a user +option 'browse-url-handlers' being alists with '(REGEXP-OR-PREDICATE +. FUNCTION)' entries allowing to define different browsing FUNCTIONs +depending on the URL to be browsed. The variable is for default +handlers provided by Emacs itself or external packages, the user +option is for the user (and allows for overriding the default +handlers). + +Formerly, one could do the same by setting +'browse-url-browser-function' to such an alist. This usage is still +supported but deprecated. + +*** Categorization of browsing functions in internal vs. external. +All standard browsing functions such as 'browse-url-firefox', +'browse-url-mail', or 'eww' have been categorized into internal (URL +is browsed in Emacs) or external (an external application is spawned +with the URL). This is done by adding a 'browse-url-browser-kind' +symbol property to the browsing functions. With a new command +'browse-url-with-browser-kind', an URL can explicitly be browsed with +either an internal or external browser. + +*** Support for the conkeror browser is now obsolete. + +** SHR -*** New user option 'js-jsx-detect-syntax' disables automatic detection. -This is turned on by default. +--- +*** The command 'shr-browse-url' now supports custom mailto handlers. +Clicking on or otherwise following a 'mailto:' link in a HTML buffer +rendered by SHR previously invoked the command 'browse-url-mailto'. +This is still the case by default, but if you customize +'browse-url-mailto-function' or 'browse-url-handlers' to call some +other function, it will now be called instead of the default. -*** New user option 'js-jsx-syntax' enables JSX syntax unconditionally. -This is off by default. ++++ +*** New user option 'shr-max-width'. +If this user option is non-nil, and 'shr-width' is nil, then SHR will +use the value of 'shr-max-width' to limit the width of the rendered +HTML. The default is 120 characters, so even if you have very wide +frames, HTML text will be rendered more narrowly, which usually leads +to a more readable text. Set this user option to nil to get the +previous behavior of rendering as wide as the 'window-width' allows. +If 'shr-width' is non-nil, it overrides this variable. -*** New variable 'js-jsx-regexps' controls JSX detection. +** Images -*** JSX syntax is now highlighted like SGML. +--- +*** Animated images stop automatically under high CPU pressure sooner. +Previously, an animated image would stop animating if any single image +took more than two seconds to display. The new algorithm maintains a +decaying average of delays, and if this number gets too high, the +animation is stopped. -*** JSX code is properly indented in many more scenarios. -Previously, JSX indentation usually only worked when an element was -wrapped in parenthesis (e.g. in a 'return' statement or a function -call). It would also fail in many intricate cases. Now, indentation -should work anywhere without parenthesis; many more intricacies are -supported; and, indentation conventions align more closely with those -of the React developer community (see 'js-jsx-align->-with-<'), -otherwise still adhering to SGML conventions. +** EWW -*** New user option 'js-jsx-align->-with-<' controls '>' indents. -Commonly in JSX code, a '>' on its own line is indented at the same -level as its opening '<'. This is the new default for JSX. This -behavior is slightly different than that used by SGML in Emacs, where -'>' is indented at the same level as attributes, which was also the -old default for JSX. ++++ +*** 'eww-download-directory' will now use the XDG location, if defined. +However, if "~/Downloads/" already exists, that will continue to be +used. -This is turned on by default. To get back the old default indentation -behavior of aligning '>' with attributes, set 'js-jsx-align->-with-<' -to nil. +--- +*** The command 'eww-follow-link' now supports custom mailto handlers. +The function that is invoked when clicking on or otherwise following a +'mailto:' link in an EWW buffer can now be customized. For more +information, see the related entry about 'shr-browse-url' above. -*** Indentation uses 'js-indent-level' instead of 'sgml-basic-offset'. -Since JSX is a syntax extension of JavaScript, it makes the most sense -for JSX expressions to be indented the same number of spaces as other -JS expressions. This is a breaking change, but it probably aligns -with how you'd expect this indentation to behave. If you want JSX to -be indented like JS, you won't need to change your config. +** Project -The old behavior can be emulated by controlling JSX indentation -independently of JS, by setting 'js-jsx-indent-level'. +*** New user option 'project-vc-merge-submodules'. -*** New user option 'js-jsx-indent-level' for different JSX indentation. -If you wish to indent JSX by a different number of spaces than JS, set -this user option to the desired number. +*** Project commands now have their own history. +Previously used project directories are now suggested by all commands +that prompt for a project directory. -*** New user option 'js-jsx-attribute-offset' for JSX attribute indents. ++++ +*** New prefix keymap 'project-prefix-map'. +Key sequences that invoke project-related commands start with the +prefix 'C-x p'. Type "C-x p C-h" to show the full list. -*** New variable 'js-syntactic-mode-name' controls mode name display. -Previously, the mode name was simply 'JavaScript'. Now, when a syntax -extension like JSX is enabled, the mode name is 'JavaScript[JSX]'. -Set this variable to nil to disable the new behavior. ++++ +*** New commands 'project-dired', 'project-vc-dir', 'project-shell', +'project-eshell'. These commands run Dired/VC-Dir and Shell/Eshell in +a project's root directory, respectively. -*** New function 'js-use-syntactic-mode-name' for deriving modes. -Packages deriving from 'js-mode' with 'define-derived-mode' should -call this function to add enabled syntax extensions to their mode -name, too. ++++ +*** New command 'project-compile'. +This command runs compilation in the current project's root +directory. -** Autorevert ++++ +*** New command 'project-switch-project'. +This command lets you "switch" to another project and run a project +command chosen from a dispatch menu. -*** New user option 'auto-revert-avoid-polling' for saving power. -When set to a non-nil value, buffers in Auto Revert mode are no longer -polled for changes periodically. This reduces the power consumption -of an idle Emacs, but may fail on some network file systems; set -'auto-revert-notify-exclude-dir-regexp' to match files where -notification is not supported. The default value is nil. ++++ +*** New user option 'project-list-file'. -*** New variable 'buffer-auto-revert-by-notification'. -A major mode can declare that notification on the buffer's default -directory is sufficient to know when updates are required, by setting -the new variable 'buffer-auto-revert-by-notification' to a non-nil -value. Auto Revert mode can use this information to avoid polling the -buffer periodically when 'auto-revert-avoid-polling' is non-nil. +** json.el -*** 'global-auto-revert-ignore-buffer' can now also be a predicate -function that can be used for more fine-grained control of which -buffers to auto-revert. +--- +*** JSON number parsing is now stricter. +Numbers with a leading plus sign, leading zeros, or a missing integer +component are now rejected by 'json-read' and friends. This makes +them more compliant with the JSON specification and consistent with +the native JSON parsing functions. -** auth-source-pass +** xml.el -*** New user option 'auth-source-pass-filename'. -Allows setting the path to the password-store, defaults to -"~/.password-store". +*** XML serialization functions now reject invalid characters. +Previously 'xml-print' would produce invalid XML when given a string +with characters that are not valid in XML (see +https://www.w3.org/TR/xml/#charsets). Now it rejects such strings. -*** New user option 'auth-source-pass-port-separator'. -Specifies separator between host and port, defaults to colon ":". +** Battery -*** Minimize the number of decryptions during password lookup. -This makes the package usable with physical tokens requiring touching -a sensor for every decryption. +--- +*** UPower is now the default battery status backend when available. +UPower support via the function 'battery-upower' was added in Emacs +26.1, but was disabled by default. It is now the default value of +'battery-status-function' when the system provides a UPower D-Bus +service. The user options 'battery-upower-device' and +'battery-upower-subscribe' control which power sources to query and +whether to respond to status change notifications in addition to +polling, respectively. -*** 'auth-source-pass-get' is now autoloaded. +--- +*** A richer syntax can be used to format battery status information. +The user options 'battery-mode-line-format' and +'battery-echo-area-format' now support the full formatting syntax of +the function 'format-spec' documented under node "(elisp) Custom Format +Strings". The new syntax includes specifiers for padding and +truncation, amongst other things. -** Bookmarks +** bug-reference.el -*** 'bookmark-file' and 'bookmark-old-default-file' are now obsolete -aliases of 'bookmark-default-file'. +--- +*** Bug reference mode auto-setup. If 'bug-reference-mode' or +'bug-reference-prog-mode' have been activated, their respective hook +has been run and still 'bug-reference-bug-regexp' and +'bug-reference-url-format' aren't both set, it tries to guess +appropriate values for those two variables. There are three guessing +mechanisms so far: based on version control information of the current +buffer's file, based on newsgroup/mail-folder name and several news +and mail message headers in Gnus buffers, and based on IRC channel and +network in rcirc and ERC buffers. All mechanisms are extensible with +custom rules, see the variables 'bug-reference-setup-from-vc-alist', +'bug-reference-setup-from-mail-alist', and +'bug-reference-setup-from-irc-alist'. -*** New user option 'bookmark-watch-bookmark-file'. -When non-nil, watch whether the bookmark file has changed on disk. + +* New Modes and Packages in Emacs 28.1 -*** The old bookmark file format is no longer supported. -This bookmark file format has not been used in Emacs since at least -version 19.34, released in 1996, and will no longer be automatically -converted to the new bookmark file format. +** Lisp Data mode -The following functions are now declared obsolete: -'bookmark-grok-file-format-version', -'bookmark-maybe-upgrade-file-format', -'bookmark-upgrade-file-format-from-0', and -'bookmark-upgrade-version-0-alist'. +The new command 'lisp-data-mode' enables a major mode for buffers +composed of Lisp symbolic expressions that do not form a computer +program. The ".dir-locals.el" file is automatically set to use this +mode, as are other data files produced by Emacs. -** The mantemp.el library is now marked obsolete. -This library generates manual C++ template instantiations. It should -no longer be useful on modern compilers, which do this automatically. + +* Incompatible Editing Changes in Emacs 28.1 -** Ispell +** In 'nroff-mode', 'center-line' is now bound to 'M-o M-s'. +The original key binding was 'M-s', which interfered with I-search, +since the latter uses 'M-s' as a prefix key of the search prefix map. -*** New hook 'ispell-change-dictionary-hook'. -This runs after changing the dictionary and could be used to -automatically spellcheck a buffer when changing language without -needing to advice 'ispell-change-dictionary'. +** 'vc-print-branch-log' shows the change log for BRANCH from its root +directory instead of the default directory. -** scroll-lock + +* Incompatible Lisp Changes in Emacs 28.1 -*** New command 'scroll-lock-next-line-always-scroll'. -This command is bound to 'S-down' and scrolls the buffer up in -particular when the end of the buffer is visible in the window. +** 'equal' no longer examines some contents of window configurations. +Instead, it considers window configurations to be equal only if they +are 'eq'. To compare contents, use 'compare-window-configurations' +instead. This change helps fix a bug in 'sxhash-equal', which returned +incorrect hashes for window configurations and some other objects. -** mwheel.el +** When its first argument is a string, 'make-text-button' no longer +modifies the string's text properties; instead, it uses and returns +a copy of the string. This helps avoid trouble when strings are +shared or constants. -*** 'mwheel-install' is now obsolete. -Use 'mouse-wheel-mode' instead. Note that 'mouse-wheel-mode' is -already enabled by default on most graphical displays. +--- +** The obsolete function 'thread-alive-p' has been removed. -** Gravatar +** 'dns-query' now consistently uses Lisp integers to represent integers. +Formerly it made an exception for integer components of SOA records, +because SOA serial numbers can exceed fixnum ranges on 32-bit platforms. +Emacs now supports bignums so this old glitch is no longer needed. -*** 'gravatar-cache-ttl' is now a number of seconds. -The previously used timestamp format of a list of integers is still -supported, but is deprecated. The default value has not changed. +** The Lisp variables 'previous-system-messages-locale' and +'previous-system-time-locale' have been removed, as they were created +by mistake and were not useful to Lisp code. -*** 'gravatar-size' can now be nil. -This results in the use of Gravatar's default size of 80 pixels. +** The 'load-dangerous-libraries' variable is now obsolete. +It was used to allow loading Lisp libraries compiled by XEmacs, a +modified version of Emacs which is no longer actively maintained. +This is no longer supported, and setting this variable has no effect. -*** The default fallback gravatar is now configurable. -This is possible using the new user options 'gravatar-default-image' -and 'gravatar-force-default'. ++++ +** The macro 'with-displayed-buffer-window' is now obsolete. +Use macro 'with-current-buffer-window' with action alist entry 'body-function'. -** ada-mode +** The metamail.el library is now marked obsolete. -*** The built-in ada-mode is now deleted. The GNU ELPA package is a -good replacement, even in very large source files. +--- +** Some obsolete variable and function aliases in dbus.el have been removed. +In Emacs 24.3, the variable 'dbus-event-error-hooks' was renamed to +'dbus-event-error-functions' and the function +'dbus-call-method-non-blocking' was renamed to 'dbus-call-method'. +The old names, which were kept as obsolete aliases of the new names, +have now been removed. -** time-stamp +--- +** Some libraries obsolete since Emacs 23 have been removed: +'ledit.el', 'lmenu.el', 'lucid.el and 'old-whitespace.el'. -*** New '%5z' conversion for 'time-stamp-format' gives time zone offset. -Specifying '%5z' in 'time-stamp-format' or 'time-stamp-pattern' -expands to the time zone offset, e.g., '+0100'. The time zone used is -specified by 'time-stamp-time-zone'. + +* Lisp Changes in Emacs 28.1 -Because this feature is new in Emacs 27.1, do not use it in the local -variables section of any file that might be edited by an older version -of Emacs. ++++ +** New function 'file-modes-number-to-symbolic' to convert a numeric +file mode specification into symbolic form. -*** Some conversions recommended for 'time-stamp-format' have changed. -The new documented/recommended %-conversions are closer to those -used by 'format-time-string' and are compatible at least as far back -as Emacs 22.1 (released in 2007). +** New macro 'dlet' to dynamically bind variables. -Uppercase abbreviated day name of week: was %3A, now %#a -Full day name of week: was %:a, now %:A -Uppercase abbreviated month name: was %3B, now %#b -Full month name: was %:b, now %:B -Four-digit year: was %:y, now %Y -Lowercase timezone name: was %z, now %#Z -Fully-qualified host name: was %s, now %Q -Unqualified host name: (was none), now %q -Login name: was %u, now %l -User's full name: was %U, now %L +** The variable 'force-new-style-backquotes' has been removed. +This removes the final remaining trace of old-style backquotes. -Merely having '(add-hook 'before-save-hook 'time-stamp)' in your -Emacs init file does not expose you to this change. However, -if you set 'time-stamp-format' or 'time-stamp-pattern' with a -file-local variable, you may need to update the value. +** The module header 'emacs-module.h' now contains type aliases +'emacs_function' and 'emacs_finalizer' for module functions and +finalizers, respectively. -** mode-local +** Module functions can now install an optional finalizer that is +called when the function object is garbage-collected. Use +'set_function_finalizer' to set the finalizer and +'get_function_finalizer' to retrieve it. -*** Declare 'define-overload' and 'define-child-mode' as obsolete. +** Modules can now open a channel to an existing pipe process using +the new module function 'open_channel'. Modules can use this +functionality to asynchronously send data back to Emacs. -*** Rename several internal functions to use a 'mode-local-' prefix. +** 'file-modes', 'set-file-modes', and 'set-file-times' now have an +optional argument specifying whether to follow symbolic links. -** CC Mode +** 'parse-time-string' can now parse ISO 8601 format strings, +such as "2020-01-15T16:12:21-08:00". -*** You can now flag "wrong style" comments with 'font-lock-warning-face'. -To do this, use 'c-toggle-comment-style', if needed, to set the desired -default comment style (block or line); then set the user option -'c-mark-wrong-style-of-comment' to non-nil. ++++ +** The new function 'dom-remove-attribute' has been added. -** Mailcap +--- +** 'make-network-process', 'make-serial-process' ':coding' behavior change. +Previously, passing ':coding nil' to either of these functions would +override any non-nil binding for 'coding-system-for-read' and +'coding-system-for-write'. For consistency with 'make-process' and +'make-pipe-process', passing ':coding nil' is now ignored. No code in +Emacs depended on the previous behavior; if you really want the +process' coding-system to be nil, use 'set-process-coding-system' +after the process has been created, or pass in ':coding '(nil nil)'. -*** The new function 'mailcap-file-name-to-mime-type' has been added. -It's a simple convenience function for looking up MIME types based on -file name extensions. ++++ +** 'open-network-stream' now accepts a ':coding' argument. +This allows specifying the coding systems used by a network process +for encoding and decoding without having to bind +'coding-system-for-{read,write}' or call 'set-process-coding-system'. -*** The default way the list of possible external viewers for MIME -types is sorted and chosen has changed. Earlier, the most specific -viewer was chosen, even if there was a general override in "~/.mailcap". -For instance, if "/etc/mailcap" has an entry for "image/gif", that one -will be chosen even if you have an entry for "image/*" in your -"~/.mailcap" file. But with the new method, entries from "~/.mailcap" -overrides all system and Emacs-provided defaults. To get the old -method back, set 'mailcap-prefer-mailcap-viewers' to nil. ++++ +** 'open-network-stream' can now take a ':capability-command' that's a function. +The function is called with the greeting from the server as its only +parameter, and allows sending different TLS capability commands to the +server based on that greeting. -** MH-E ++++ +** 'open-gnutls-stream' now also accepts a ':coding' argument. -*** The hook 'mh-show-mode-hook' is now called before the message is inserted. -Functions that want to affect the message text (for example, to change -highlighting) can no longer use 'mh-show-mode-hook', because the -message contents will not yet have been inserted when the hook is -called. Such functions should now be attached to 'mh-show-hook'. ++++ +** New user option 'process-file-return-signal-string'. +It controls, whether 'process-file' returns a string when a remote +process is interrupted by a signal. -** URL ++++ +** The behavior of 'format-spec' is now closer to that of 'format'. +In order for the two functions to behave more consistently, +'format-spec' now pads and truncates based on string width rather than +length, and also supports format specifications that include a +truncating precision field, such as "%.2a". -*** The 'file:' handler no longer looks for "index.html" in -directories if you ask it for a "file:///dir" URL. Since this is a -low-level library, such decisions (if they are to be made at all) are -left to higher-level functions. +--- +** New function 'color-values-from-color-spec'. +This can be used to parse RGB color specs in several formats and +convert them to a list '(R G B)' of primary color values. -* New Modes and Packages in Emacs 27.1 - -** Tab Bars - -*** Tab Bar mode -The new command 'tab-bar-mode' enables the tab bar at the top of each -frame (including TTY frames), where you can use tabs to switch between -named persistent window configurations. - -The 'C-x t' sequence is the new prefix key for tab-related commands: -'C-x t 2' creates a new tab; 'C-x t 0' deletes the current tab; -'C-x t b' switches to buffer in another tab; 'C-x t f' and 'C-x t C-f' -edit file in another tab; and 'C-TAB' and 'S-C-TAB' switch to the next -or previous tab. You can also switch between tabs and create/delete -tabs with a mouse. - -Tab-related commands are available even when 'tab-bar-mode' is -disabled: by default, they enable 'tab-bar-mode' in that case. - -The X resource "tabBar", class "TabBar" enables the tab bar -when its value is "on", "yes" or "1". - -The user option 'tab-bar-position' specifies where to show the tab bar. - -Tab-related commands can be used even without the tab bar when -'tab-bar-mode' is disabled by a nil value of the user option -'tab-bar-show'. Without the tab bar you can switch between tabs -using completion on tab names, or using 'tab-switcher'. - -Read the new Info node "(emacs) Tab Bars" for full description -of all related features. - -*** Tab Line mode -The new command 'global-tab-line-mode' enables the tab line above each -window, which you can use to switch buffers in the window. Selecting -the previous window-local tab is the same as typing 'C-x <LEFT>' -('previous-buffer'), selecting the next tab is the same as 'C-x <RIGHT>' -('next-buffer'). Both commands support a numeric prefix argument as -a repeat count. Clicking on the plus icon adds a new buffer to the -window-local tab line of buffers. Using the mouse wheel on the tab -line scrolls tabs. - -Read the new Info node "(emacs) Tab Line" for full description -of all related features. - -** fileloop.el lets one setup multifile operations like search&replace. - -** Emacs can now visit files in archives as if they were directories. -This feature uses Tramp and works only on systems which support GVFS, -i.e. GNU/Linux, roughly spoken. See the node "(tramp) Archive file -names" in the Tramp manual for full documentation of these facilities. - -** New library for writing JSONRPC applications (https://jsonrpc.org). -The 'jsonrpc' library enables writing Emacs Lisp applications that -rely on this protocol. Since the protocol is designed to be -transport-agnostic, the library provides an API to implement new -transport strategies as well as a separate API to use them. A -transport implementation for process-based communication, such as is -used by the Language Server Protocol (LSP), is readily available. - -** Backtrace mode improves viewing of Elisp backtraces. -Backtrace mode adds pretty printing, fontification and ellipsis -expansion to backtrace buffers produced by the Lisp debugger, Edebug -and ERT. See the node "(elisp) Backtraces" in the Elisp manual for -documentation of the new mode and its commands. - -** so-long.el helps to mitigate performance problems with long lines. -When 'global-so-long-mode' has been enabled, visiting a file with very -long lines will (subject to configuration) cause the user's preferred -'so-long-action' to be automatically invoked (by default, the buffer's -major mode is replaced by 'so-long-mode'). In extreme cases this can -prevent delays of several minutes, and make Emacs responsive almost -immediately. Type 'M-x so-long-commentary' for full documentation. +* Changes in Emacs 28.1 on Non-Free Operating Systems - -* Incompatible Lisp Changes in Emacs 27.1 - -** Incomplete destructive splicing support has been removed. -Support for Common Lisp style destructive splicing (",.") was -incomplete and broken for a long time. It has now been removed. - -This means that backquote substitution now works for identifiers -starting with a period ("."). Consider the following example: - - (let ((.foo 42)) `,.foo) - -In the past, this would have incorrectly evaluated to '(\,\. foo)', -but will now instead evaluate to '42'. - -** The REGEXP in 'magic-mode-alist' is now matched case-sensitively. -Likewise for 'magic-fallback-mode-alist'. - -** 'add-hook' does not always add to the front or the end any more. -The replacement of 'append' with 'depth' implies that the function is -not always added to the very front (when append/depth is nil) or the -very end (when append/depth is t) any more because other functions on -the hook may have specified higher/lower depths. This makes it -possible to control the ordering of functions more precisely, as was -already possible in 'add-function' and 'advice-add'. - -** In 'compilation-error-regexp-alist' the old undocumented feature -where 'line' could be a function of 2 arguments has been dropped. - -** 'define-fringe-bitmap' is always defined, even when Emacs is built -without any GUI support. - -** Just loading a theme's file no longer activates the theme's settings. -Loading a theme with 'M-x load-theme' still activates the theme, as it -did before. However, loading the theme's file with 'M-x load-file', -or using 'require' or 'load' in a Lisp program, doesn't actually apply -the theme's settings until you either invoke 'M-x enable-theme' or -type 'M-x load-theme'. (In a Lisp program, calling 'enable-theme' or -invoking 'load-theme' with NO-ENABLE argument omitted or nil has the -same effect of activating a theme whose file has been loaded.) The -special case of the 'user' theme is an exception: it is frequently -used for ad-hoc customizations, so the settings of that theme are by -default applied immediately. - -The variable 'custom--inhibit-theme-enable' controls this behavior; -its default value changed in Emacs 27.1. - -** The REPETITIONS argument of 'benchmark-run' can now also be a variable. - -** Interpretation of relative 'HOME' directory has changed. -If "$HOME" is set to a relative file name, 'expand-file-name' now -interprets it relative to the directory where Emacs was started, not -relative to the 'default-directory' of the current buffer. We recommend -always setting "$HOME" to an absolute file name, so that its meaning is -independent of where Emacs was started. - -** 'file-name-absolute-p' no longer considers "~foo" to be an absolute -file name if there is no user named "foo". - -** The FILENAME argument to 'file-name-base' is now mandatory and no -longer defaults to 'buffer-file-name'. - -** File metadata primitives now signal an error if I/O, access, or -other serious errors prevent them from determining the result. -Formerly, these functions often (though not always) silently returned -nil. For example, if there is an access error, I/O error or low-level -integer overflow when getting the attributes of a file F, -'(file-attributes F)' now signals an error instead of returning nil. -These functions still behave as before if the only problem is that the -file does not exist. The affected primitives are -'directory-files-and-attributes', 'file-acl', 'file-attributes', -'file-modes', 'file-newer-than-file-p', 'file-selinux-context', -'file-system-info', and 'set-visited-file-modtime'. - -** The function 'eldoc-message' now accepts a single argument. -Programs that called it with multiple arguments before should pass -them through 'format' first. Even that is discouraged: for ElDoc -support, you should set 'eldoc-documentation-function' instead of -calling 'eldoc-message' directly. - -** Old-style backquotes now generate an error. -They have been generating warnings for a decade. To interpret -old-style backquotes as new-style, bind the new variable -'force-new-style-backquotes' to t. - -** Defining a Common Lisp structure using 'cl-defstruct' or -'cl-struct-define' whose name clashes with a builtin type (e.g., -'integer' or 'hash-table') now signals an error. - -** When formatting a floating-point number as an octal or hexadecimal -integer, Emacs now signals an error if the number is too large for the -implementation to format. - -** 'logb' now returns infinity when given an infinite or zero argument, -and returns a NaN when given a NaN. Formerly, it returned an extreme -fixnum for such arguments. - -** Some functions and variables obsolete since Emacs 22 have been removed: -'archive-mouse-extract', 'assoc-ignore-case', 'assoc-ignore-representation', -'backward-text-line', 'blink-cursor', 'bookmark-exit-hooks', -'c-opt-op-identitier-prefix', 'comint-use-prompt-regexp-instead-of-fields', -'compilation-finish-function', 'count-text-lines', 'cperl-vc-header-alist', -'custom-face-save-command', 'cvs-display-full-path', 'cvs-fileinfo->full-path', -'delete-frame-hook', 'derived-mode-class', 'describe-char-after', -'describe-project', 'desktop-basefilename', 'desktop-buffer-handlers', -'desktop-buffer-misc-functions', 'desktop-buffer-modes-to-save', -'desktop-enable', 'desktop-load-default', 'dired-omit-files-p', -'disabled-command-hook', 'dungeon-mode-map', 'electric-nroff-mode', -'electric-nroff-newline', 'electric-perl-terminator', 'executing-macro', -'focus-frame', 'forward-text-line', 'generic-define-mswindows-modes', -'generic-define-unix-modes', 'generic-font-lock-defaults', -'goto-address-at-mouse', 'highlight-changes-colours', -'ibuffer-elide-long-columns', 'ibuffer-hooks', 'ibuffer-mode-hooks', -'icalendar-convert-diary-to-ical', 'icalendar-extract-ical-from-buffer', -'imenu-always-use-completion-buffer-p', 'ipconfig-program', -'ipconfig-program-options', 'isearch-lazy-highlight-cleanup', -'isearch-lazy-highlight-initial-delay', 'isearch-lazy-highlight-interval', -'isearch-lazy-highlight-max-at-a-time', 'iswitchb-use-fonts', -'latin1-char-displayable-p', 'mouse-wheel-click-button', -'mouse-wheel-down-button', 'mouse-wheel-up-button', 'new-frame', -'pascal-outline', 'process-kill-without-query', -'recentf-menu-append-commands-p', 'rmail-pop-password', -'rmail-pop-password-required', 'savehist-load', 'set-default-font', -'spam-list-of-processors', 'speedbar-add-ignored-path-regexp', -'speedbar-buffers-line-path', 'speedbar-ignored-path-expressions', -'speedbar-ignored-path-regexp', 'speedbar-line-path', 'speedbar-path-line', -'timer-set-time-with-usecs', 'tooltip-gud-display', 'tooltip-gud-modes', -'tooltip-gud-toggle-dereference', 'unfocus-frame', 'unload-hook-features-list', -'update-autoloads-from-directories', 'vc-comment-ring', 'vc-comment-ring-index', -'vc-comment-search-forward', 'vc-comment-search-reverse', -'vc-comment-to-change-log', 'vc-diff-switches-list', 'vc-next-comment', -'vc-previous-comment', 'view-todo', 'x-lost-selection-hooks', -'x-sent-selection-hooks'. - -** Further functions and variables obsolete since Emacs 24 have been removed: -'default-directory-alist', 'dired-default-directory', -'dired-default-directory-alist', 'dired-enable-local-variables', -'dired-hack-local-variables', 'dired-local-variables-file', -'dired-omit-here-always'. - -** Garbage collection no longer treats miscellaneous objects specially; -they are now allocated like any other pseudovector. As a result, the -'garbage-collect' and 'memory-use-count' functions no longer return a -'misc' component, and the 'misc-objects-consed' variable has been -removed. - -** Reversed character ranges are no longer permitted in 'rx'. -Previously, ranges where the starting character is greater than the -ending character were silently omitted. -For example, '(rx (any "@z-a" (?9 . ?0)))' would match '@' only. -Now, such 'rx' expressions generate an error. - -** Internal 'rx' functions and variables have been removed, -as a consequence of an improved implementation. Packages using -these should use the public 'rx' and 'rx-to-string' instead. -'rx-constituents' is still available for compatibility, but the new -extension mechanism is preferred: 'rx-define', 'rx-let' and -'rx-let-eval'. - -** 'text-mode' no longer sets the value of 'indent-line-function'. -The global value of 'indent-line-function', which defaults to -'indent-relative', will no longer be reset locally when turning on -'text-mode'. - -To get back the old behavior, add a function to 'text-mode-hook' which -performs '(setq-local indent-line-function #'indent-relative)'. - -** 'make-process' no longer accepts a non-nil ':stop' key. This has -never worked reliably, and now causes an error. - -** 'eventp' no longer returns non-nil for lists whose car is nil. -This is consistent with the fact that nil, though a symbol, is not a -valid event type. - -** The obsolete package xesam.el (since Emacs 24) has been removed. - -** The XBM image handler now accepts a ':stride' argument, which should -be specified in image specs representing the entire bitmap as a single -bool vector. - -** 'regexp-quote' may return its argument string. -If the argument needs no quoting, it can be returned instead of a copy. - -** Mouse scroll up and down with control key modifier changes font size. -Previously, the control key modifier was used to scroll up or down by -an amount which was close to near a full screen. This is now instead -available by scrolling with the meta modifier key. - -To get the old behavior back, customize the user option -'mouse-wheel-scroll-amount', or add the following to your init file: - -(customize-set-variable 'mouse-wheel-scroll-amount - '(5 ((shift) . 1) ((control) . nil))) - -By default, the font size will be changed in the window that the mouse -pointer is over. To change this behavior, you can customize the user -option 'mouse-wheel-follow-mouse'. Note that this will also affect -scrolling. - -** Mouse scroll up and down with control key modifier also works on images -where it scales the image under the mouse pointer. - -** 'help-follow-symbol' now signals 'user-error' if point (or the -position pointed to by the argument POS) is not in a symbol. - -** The options.el library has been removed. -It was obsolete since Emacs 22.1, replaced by customize. - -** The tls.el and starttls.el libraries are now marked obsolete. -Use of built-in libgnutls based functionality (described in the Emacs -GnuTLS manual) is recommended instead. - -** The url-ns.el library is now marked obsolete. -This library is used to open configuration files for the long defunct -web browser Netscape, and is no longer relevant. ++++ +** On macOS, Emacs can now load dynamic modules with a ".dylib" suffix. +'module-file-suffix' now has the value ".dylib" on macOS, but the +".so" suffix is supported as well. - -* Lisp Changes in Emacs 27.1 - -** Emacs Lisp integers can now be of arbitrary size. -Emacs uses the GNU Multiple Precision (GMP) library to support -integers whose size is too large to support natively. The integers -supported natively are known as "fixnums", while the larger ones are -"bignums". The new predicates 'bignump' and 'fixnump' can be used to -distinguish between these two types of integers. - -All the arithmetic, comparison, and logical (a.k.a. "bitwise") -operations where bignums make sense now support both fixnums and -bignums. However, note that unlike fixnums, bignums will not compare -equal with 'eq', you must use 'eql' instead. (Numerical comparison -with '=' works on both, of course.) - -Since large bignums consume a lot of memory, Emacs limits the size of -the largest bignum a Lisp program is allowed to create. The -nonnegative value of the new variable 'integer-width' specifies the -maximum number of bits allowed in a bignum. Emacs signals an integer -overflow error if this limit is exceeded. - -Several primitive functions formerly returned floats or lists of -integers to represent integers that did not fit into fixnums. These -functions now simply return integers instead. Affected functions -include functions like 'encode-char' that compute code-points, functions -like 'file-attributes' that compute file sizes and other attributes, -functions like 'process-id' that compute process IDs, and functions like -'user-uid' and 'group-gid' that compute user and group IDs. - -** 'overflow-error' is now documented as a subcategory of 'range-error'. -Formerly it was undocumented, and was (incorrectly) a subcategory -of 'domain-error'. - -** Time values - -*** New function 'time-convert' converts Lisp time values to Lisp -timestamps of various forms, including a new timestamp form '(TICKS -. HZ)' where TICKS is an integer and HZ a positive integer denoting a -clock frequency. - -*** Although the default timestamp format is still '(HI LO US PS)', -it is planned to change in a future Emacs version, to exploit bignums. -The documentation has been updated to mention that the timestamp -format may change and that programs should use functions like -'format-time-string', 'decode-time', and 'time-convert' rather than -probing the innards of a timestamp directly, or creating a timestamp -by hand. - -*** Decoded (calendrical) timestamps now have subsecond resolution. -This affects 'decode-time', which generates these timestamps, as well -as functions like 'encode-time' that accept them. The subsecond info -is present as a '(TICKS . HZ)' value in the seconds element of a -decoded timestamp, and 'decode-time' has a new optional FORM argument -specifying the form of the seconds member. For example, if X is the -timestamp '(1566009571321878186 . 1000000000)', which represents -"2019-08-17 02:39:31.321878186 UTC", '(decode-time X t t)' returns -'((31321878186 . 1000000000) 39 2 17 8 2019 6 nil 0)' instead of the -traditional '(31 39 2 17 8 2019 6 nil 0)' returned by plain -'(decode-time X t)'. Although the default FORM is currently -'integer', which truncates the seconds to an integer and is the -traditional behavior, this default may change in future Emacs -versions, so callers requiring an integer should specify FORM -explicitly. - -*** 'encode-time' supports a new API '(encode-time TIME)'. -The old 'encode-time' API is still supported. - -*** A new package to parse ISO 8601 time, date, durations and -intervals has been added. The main function to use is -'iso8601-parse', but there's also 'iso8601-parse-date', -'iso8601-parse-time', 'iso8601-parse-duration' and -'iso8601-parse-interval'. All these functions return decoded time -structures, except the final one, which returns three of them (start, -end and duration). - -*** 'time-add', 'time-subtract', and 'time-less-p' now accept -infinities and NaNs too, and propagate them or return nil like -floating-point operators do. If both arguments are finite, these -functions now return exact results instead of rounding in some cases, -and they also avoid excess precision when that is easy. - -*** New function 'time-equal-p' compares time values for equality. - -*** 'format-time-string' supports a new conversion specifier flag '+' -that acts like the '0' flag but also puts a '+' before nonnegative -years containing more than four digits. This is for compatibility -with POSIX.1-2017. - -*** To access (or alter) the elements of a decoded time value, the -'decoded-time-second', 'decoded-time-minute', 'decoded-time-hour', -'decoded-time-day', 'decoded-time-month', 'decoded-time-year', -'decoded-time-weekday', 'decoded-time-dst' and 'decoded-time-zone' -accessors can be used. - -*** The new functions 'date-days-in-month' (which will say how many -days there are in a month in a specific year), 'date-ordinal-to-time' -(that computes the date of an ordinal day), 'decoded-time-add' (for -doing computations on a decoded time structure), 'make-decoded-time' -(for making a decoded time structure with only the given keywords -filled out), and 'encoded-time-set-defaults' (which fills in nil -elements as if it's midnight January 1st, 1970) have been added. - -*** In the DST slot, 'encode-time' and 'parse-time-string' now return -1 -if it is not known whether daylight saving time is in effect. -Formerly they were inconsistent: 'encode-time' returned t in this -situation, whereas 'parse-time-string' returned nil. Now they -consistently use nil to mean that DST is not in effect, and use -1 -to mean that it is not known whether DST is in effect. - -** New macro 'benchmark-progn'. -This macro works like 'progn', but messages how long it takes to -evaluate the body forms. The value of the last form is the return -value. - -** New function 'read-char-from-minibuffer'. -This function works like 'read-char', but uses 'read-from-minibuffer' -to read a character, so it maintains a history that can be navigated -via usual minibuffer keystrokes 'M-p'/'M-n'. - -** New variables 'set-message-function' and 'clear-message-function' -can be used to specify functions to show and clear messages that -normally are displayed in the echo area. - -** 'setq-local' can now set an arbitrary number of variables, which -makes the syntax more like 'setq'. - -** 'reveal-mode' can now also be used for more than to toggle between -invisible and visible: It can also toggle 'display' properties in -overlays. This is only done on 'display' properties that have the -'reveal-toggle-invisible' property set. - -** 'process-contact' now takes an optional NO-BLOCK argument to allow -not waiting for a process to be set up. - -** New variable 'read-process-output-max' controls sub-process throughput. -This variable determines how many bytes can be read from a sub-process -in one read operation. The default, 4096 bytes, was previously a -hard-coded constant. Setting it to a larger value might enhance -throughput of reading from sub-processes that produces vast -(megabytes) amounts of data in one go. - -** The new user option 'quit-window-hook' is now run first when -executing the 'quit-window' command. - -** The user options 'help-enable-completion-auto-load', -'help-enable-auto-load' and 'vhdl-project-auto-load', as well as the -function 'vhdl-auto-load-project' have been renamed to have "autoload" -without the hyphen in their names. Obsolete aliases from the old -names have been added. - -** Buttons (created with 'make-button' and related functions) can -now use the 'button-data' property. If present, the data in this -property will be passed on to the 'action' function instead of the -button itself in 'button-activate'. - -** 'defcustom' now takes a ':local' keyword that can be either t or -'permanent', which mean that the variable should be automatically -buffer-local. 'permanent' also sets the variable's 'permanent-local' -property. - -** The new macro 'with-suppressed-warnings' can be used to suppress -specific byte-compile warnings. - -** The new macro 'ignore-error' is like 'ignore-errors', but takes a -specific error condition, and will only ignore that condition. (This -can also be a list of conditions.) - -** The new function 'byte-compile-info-message' can be used to output -informational messages that look pleasing during the Emacs build. - -** New 'help-fns-describe-variable-functions' hook. -It makes it possible to add metadata information to 'describe-variable'. - -** i18n (internationalization) - -*** 'ngettext' can be used now to return the right plural form -according to the given numeric value. - -** 'inhibit-null-byte-detection' is renamed to 'inhibit-nul-byte-detection'. - -** 'self-insert-command' takes the char to insert as (optional) argument. - -** 'lookup-key' can take a list of keymaps as argument. - -** 'condition-case' now accepts t to match any error symbol. - -** New function 'proper-list-p'. -Given a proper list as argument, this predicate returns its length; -otherwise, it returns nil. 'format-proper-list-p' is now an obsolete -alias for the new function. - -** 'define-minor-mode' automatically documents the meaning of ARG. - -** The function 'recenter' now accepts an additional optional argument. -By default, calling 'recenter' will not redraw the frame even if -'recenter-redisplay' is non-nil. Call 'recenter' with the new second -argument non-nil to force redisplay per 'recenter-redisplay's value. - -** New functions 'major-mode-suspend' and 'major-mode-restore'. -Use them when switching temporarily to another major mode, e.g. for -'hexl-mode', or to switch between 'c-mode' and 'image-mode' in XPM. - -** New macro 'dolist-with-progress-reporter'. -This works like 'dolist', but reports progress similar to -'dotimes-with-progress-reporter'. - -** New hook 'after-delete-frame-functions'. -This works like 'delete-frame-functions', but runs after the frame to -be deleted has been made dead and removed from the frame list. - -** The function 'provided-mode-derived-p' was extended to support aliases. -The function now returns non-nil when the argument MODE is derived -from any alias of any of MODES. - -** New frame focus state inspection interface. -The hooks 'focus-in-hook' and 'focus-out-hook' are now obsolete. -Instead, attach to 'after-focus-change-function' using 'add-function' -and inspect the focus state of each frame using 'frame-focus-state'. - -** Emacs now requests and recognizes focus-change notifications from TTYs. -On terminal emulators that support the feature, Emacs can now support -'focus-in-hook' and 'focus-out-hook' for TTY frames. - -** Window-specific face remapping. -Face specifications (of the kind used in 'face-remapping-alist') -now support filters, allowing faces to vary between different windows -displaying the same buffer. See the node "(elisp) Face Remapping" -of the Emacs Lisp Reference manual for more detail. - -** Window change functions have been redesigned. -Hooks reacting to window changes run now only when redisplay detects -that a change has actually occurred. Six hooks are now provided: -'window-buffer-change-functions' (run after window buffers have -changed), 'window-size-change-functions' (run after a window was -assigned a new buffer or size), 'window-configuration-change-hook' -(like the former but run also when a window was deleted), -'window-selection-change-functions' (run when the selected window -changed) and 'window-state-change-functions' and -'window-state-change-hook' (run when any of the preceding ones is -run). Applications can enforce running the latter two using the new -function 'set-frame-window-state-change'. 'window-scroll-functions' -are unaffected by these changes. - -In addition, a number of functions now allow the caller to detect what -has changed since last redisplay: 'window-old-buffer' returns for any -window the buffer it showed at that time. 'old-selected-window' and -'old-selected-frame' return the window and frame that were selected -during last redisplay. 'window-old-pixel-width' (renamed from -'window-pixel-width-before-size-change'), 'window-old-pixel-height' -(renamed from 'window-pixel-height-before-size-change'), -'window-old-body-pixel-width' and 'window-old-body-pixel-height' -return the total and body sizes of any window during last redisplay. - -Also 'run-window-configuration-change-hook' is declared obsolete. - -See the section "(elisp) Window Hooks" in the Elisp manual for a -detailed explanation of the new behavior. - -** Scroll bar and fringe settings can now be made persistent for windows. -The functions 'set-window-scroll-bars' and 'set-window-fringes' now -have a new optional argument that makes the settings they produce -reliably survive subsequent invocations of 'set-window-buffer'. - -** New user option 'resize-mini-frames'. -This option allows automatically resizing minibuffer-only frames -similarly to how minibuffer windows are resized on "normal" frames. - -** New buffer display action function 'display-buffer-in-direction'. -This function allows specifying the location of the window chosen by -'display-buffer' in various ways. - -** New buffer display action alist entry 'dedicated'. -Such an entry allows specifying the dedicated status of a window -created by 'display-buffer'. - -** New buffer display action alist entry 'window-min-height'. -Such an entry allows specifying a minimum height of the window used -for displaying a buffer. 'display-buffer-below-selected' is the only -action function to respect it at the moment. - -** New buffer display action alist entry 'direction'. -This entry is used to specify the location of the window chosen by -'display-buffer-in-direction'. - -** Additional meaning of display action alist entry 'window'. -A 'window' entry can now also specify a reference window for -'display-buffer-in-direction'. - -** The function 'assoc-delete-all' now takes an optional predicate argument. - -** New function 'string-distance' to calculate the Levenshtein distance -between two strings. - -** 'print-quoted' now defaults to t, so if you want to see -'(quote x)' instead of 'x you will have to bind it to nil where applicable. - -** Numbers formatted via '%o' or '%x' are now formatted as signed integers. -This avoids problems in calls like '(read (format "#x%x" -1))', and is -more compatible with bignums. To get the traditional machine-dependent -behavior, set the experimental variable 'binary-as-unsigned' to t, -and if the new behavior breaks your code please email -<32252@debbugs.gnu.org>. Because '%o' and '%x' can now format signed -integers, they now support the '+' and space flags. - -** In Emacs Lisp mode, symbols with confusable quotes are highlighted. -For example, the first character in '‘foo' would be highlighted in -'font-lock-warning-face'. - -** Omitting variables after '&optional' and '&rest' is now allowed. -For example '(defun foo (&optional))' is no longer an error. This is -sometimes convenient when writing macros. See the ChangeLog entry -titled "Allow '&rest' or '&optional' without following variable -(Bug#29165)" for a full listing of which arglists are accepted across -versions. - -** Internal parsing commands now use 'syntax-ppss' and disregard -'open-paren-in-column-0-is-defun-start'. This affects mostly things like -'forward-comment', 'scan-sexps', and 'forward-sexp' when parsing backward. -The new variable 'comment-use-syntax-ppss' can be set to nil to recover -the old behavior if needed. -This also means that there is no longer any need to precede opening -brackets at the start of a line inside documentation strings with a -backslash, although there is no harm in doing so to make the code -easier to edit with an older Emacs version. - -** New symbolic accessor functions for a parse state list. -The new accessor functions 'ppss-depth', 'ppss-list-start', -'ppss-last-sexp-start', 'ppss-string-terminator', 'comment-depth', -'quoted-p', 'comment-style', 'comment-or-string-start', 'open-parens', -and 'two-character-syntax' can be used on the list value returned by -'parse-partial-sexp' and 'syntax-ppss'. - -** The 'server-name' and 'server-socket-dir' variables are set when a -socket has been passed to Emacs. - -** The 'file-system-info' function is now available on all platforms. -instead of just Microsoft platforms. This fixes a 'get-free-disk-space' -bug on OS X 10.8 and later. - -** The function 'get-free-disk-space' returns now a non-nil value for -remote systems, which support this check. - -** 'memory-limit' now returns a better estimate of memory consumption. - -** When interpreting 'gc-cons-percentage', Emacs now estimates the -heap size more often and (we hope) more accurately. E.g., formerly -'(progn (let ((gc-cons-percentage 0.8)) BODY1) BODY2)' continued to use -the 0.8 value during BODY2 until the next garbage collection, but that -is no longer true. Applications may need to re-tune their GC tricks. - -** New macro 'combine-change-calls' arranges to call the change hooks -('before-change-functions' and 'after-change-functions') just once -each around a sequence of lisp forms, given a region. This is -useful when a function makes a possibly large number of repetitive -changes and the change hooks are time consuming. - -** 'eql', 'make-hash-table', etc. now treat NaNs consistently. -Formerly, some of these functions ignored signs and significands of -NaNs. Now, all these functions treat NaN signs and significands as -significant. For example, '(eql 0.0e+NaN -0.0e+NaN)' now returns nil -because the two NaNs have different signs; formerly it returned t. -Also, Emacs now reads and prints NaN significands; e.g., if X is a -NaN, '(format "%s" X)' now returns "0.0e+NaN", "1.0e+NaN", etc., -depending on X's significand. - -** The function 'make-string' accepts an additional optional argument. -If the optional third argument is non-nil, 'make-string' will produce -a multibyte string even if its second argument is an ASCII character. - -** '(format "%d" X)' no longer mishandles a floating-point number X that -does not fit in a machine integer. - -** New coding-system 'ibm038'. -This is the International EBCDIC encoding, also available as aliases -'ebcdic-int' and 'cp038'. - -** New JSON parsing and serialization functions 'json-serialize', -'json-insert', 'json-parse-string', and 'json-parse-buffer'. These -are implemented in C using the Jansson library. - -** New function 'ring-resize'. -'ring-resize' can be used to grow or shrink a ring. - -** New function 'flatten-tree'. -'flatten-list' is provided as an alias. These functions take a tree -and 'flatten' it such that the result is a list of all the terminal -nodes. - -** 'zlib-decompress-region' can partially decompress corrupted data. -If the new optional ALLOW-PARTIAL argument is passed, then the data -that was decompressed successfully before failing will be inserted -into the buffer. - -** Image mode - -*** New library Exif. -An Exif library has been added that can parse JPEG files and output -data about creation times and orientation and the like. -'exif-parse-file' and 'exif-parse-buffer' are the main interface -functions. - -*** 'image-mode' now uses this library to automatically rotate images -according to the orientation in the Exif data, if any. - -*** The command 'image-rotate' now accepts a prefix argument. -With a prefix argument, 'image-rotate' now rotates the image at point -90 degrees counter-clockwise, instead of the default clockwise. - -*** In 'image-mode' the image is resized automatically to fit in window. -By default, the image will resize upon first display and whenever the -window's dimensions change. Two user options 'image-auto-resize' and -'image-auto-resize-on-window-resize' control the resizing behavior -(including the possibility to disable auto-resizing). A new prefix -key 's' contains the commands that can be used to fit the image to the -window manually. - -*** Some 'image-mode' variables are now buffer-local. -The image parameters 'image-transform-rotation', -'image-transform-scale' and 'image-transform-resize' are now declared -buffer-local, so each buffer could have its own values for these -parameters. - -*** Three new 'image-mode' commands have been added: 'm', which marks -the file in the dired buffer(s) for the directory the file is in; 'u', -which unmarks the file; and 'w', which pushes the current buffer's file -name to the kill ring. - -*** New library image-converter. -If you need to view exotic image formats for which Emacs doesn't have -native support, customize the new user option -'image-use-external-converter' to t. If your system has -GraphicsMagick, ImageMagick or 'ffmpeg' installed, they will then be -used to convert images automatically before displaying them. - -*** 'auto-mode-alist' now includes many of the types typically -supported by the external image converters, like WEPB, BMP and ICO. -These now default to using 'image-mode'. - -*** 'imagemagick-types-inhibit' disables using ImageMagick by default. -'image-mode' started using ImageMagick by default for all images -some years back. It now respects 'imagemagick-types-inhibit' as a way -to disable that. - -** Modules - -*** The function 'load' now behaves correctly when loading modules. -Specifically, it puts the module name into 'load-history', prints -loading messages if requested, and protects against recursive loads. - -*** New module environment function 'process_input' to process user -input while module code is running. - -*** New module environment functions 'make_time' and 'extract_time' to -convert between timespec structures and Emacs Lisp time values. - -*** New module environment functions 'make_big_integer' and -'extract_big_integer' to create and extract arbitrary-size integer -values. - -*** emacs-module.h now defines a macro 'EMACS_MAJOR_VERSION' that expands -to the major version of the latest Emacs supported by the header. - -** The function 'read-variable' now uses its own history list. -The history of variable names read by 'read-variable' is recorded in -the new variable 'custom-variable-history'. - -** The functions 'string-to-unibyte' and 'string-to-multibyte' are no -longer declared obsolete. We have found that there are legitimate use -cases for these functions, where there's no better alternative. We -believe that the incorrect uses of these functions all but disappeared -by now, so we are un-obsoleting them. - -** New function 'group-name' returns a group name corresponding to GID. - -** 'make-process' now takes a keyword argument ':file-handler'; if -that is non-nil, it will look for a file name handler for the current -buffer's 'default-directory' and invoke that file name handler to make -the process. That way 'make-process' can start remote processes. - -** '(locale-info 'paper)' now returns the paper size on systems that support it. -This is currently supported on GNUish hosts and on modern versions of -MS-Windows. - -** The function 'regexp-opt', when given an empty list of strings, now -returns a regexp that never matches anything, which is an identity for -this operation. Previously, the empty string was returned in this -case. - -** New constant 'regexp-unmatchable' contains a never-matching regexp. -It is a convenient and readable way to specify a regexp that should -not match anything, and is as fast as any such regexp can be. - -** New functions to handle the URL variant of base-64 encoding. -New functions 'base64url-encode-string' and 'base64url-encode-region' -implement the url-variant of base-64 encoding as defined in RFC4648. - -The functions 'base64-decode-string' and 'base64-decode-region' now -accept an optional argument to decode the URL variant of base-64 -encoding. - -** The function 'file-size-human-readable' accepts more optional arguments. -The new third argument is a string put between the number and unit; it -defaults to the empty string. The new fourth argument is a string -representing the unit to use; it defaults to "B" when the second -argument is 'iec' and the empty string otherwise. We recommend a -space or non-breaking space as third argument, and "B" as fourth -argument, circumstances allowing. - -** 'format-spec' has been expanded with several modifiers to allow -greater flexibility when customizing variables. The modifiers include -zero-padding, upper- and lower-casing, and limiting the length of the -interpolated strings. The function has now also been documented in -the Emacs Lisp manual. - -** 'directory-files-recursively' can now take an optional PREDICATE -parameter to control descending into subdirectories, and a -FOLLOW-SYMLINK parameter to say that symbolic links that point to -other directories should be followed. - -** New function 'xor' returns the boolean exclusive-or of its args. -The function was previously defined in array.el, but has been moved to -subr.el so that it is available by default. It now always returns the -non-nil argument when the other is nil. Several duplicates of 'xor' -in other packages are now obsolete aliases of 'xor'. - -** 'define-globalized-minor-mode' now takes BODY forms. - -** New text property 'help-echo-inhibit-substitution'. -Setting this on the first character of a help string disables -conversions via 'substitute-command-keys'. - -** New text property 'minibuffer-message'. -Setting this on a character of the minibuffer text will display the -temporary echo messages before that character, when messages need to -be displayed while minibuffer is active. - -** 'undo' can be made to ignore the active region for a command -by setting 'undo-inhibit-region' symbol property of that command to -non-nil. This is used by 'mouse-drag-region' to make the effect -easier to undo immediately afterwards. - -** When called interactively, 'next-buffer' and 'previous-buffer' now -signal 'user-error' if there is no buffer to switch to. ++++ +** On MS-Windows, Emacs can now toggle the IME. +A new function 'w32-set-ime-open-status' can now be used to disable +and enable the MS-Windows native Input Method Editor (IME) at run +time. A companion function 'w32-get-ime-open-status' returns the +current IME activation status. - -* Changes in Emacs 27.1 on Non-Free Operating Systems - -** Battery status is now supported in all Cygwin builds. -Previously it was supported only in the Cygwin-w32 build. - -** Emacs now handles key combinations involving the macOS "command" -and "option" modifier keys more correctly. - -** MacOS modifier key behavior is now more adjustable. -The behavior of the macOS "Option", "Command", "Control" and -"Function" keys can now be specified separately for use with -ordinary keys, function keys and mouse clicks. This allows using them -in their standard macOS way for composing characters. - -** The special handling of 'frame-title-format' on NS where setting it -to t would enable the macOS proxy icon has been replaced with a -separate variable, 'ns-use-proxy-icon'. 'frame-title-format' will now -work as on other platforms. - -** New primitive 'w32-read-registry'. -This primitive lets Lisp programs access the MS-Windows Registry by -retrieving values stored under a given key. It is intended to be used -for supporting features such as XDG-like location of important files -and directories. - -** The default value of 'w32-pipe-read-delay' is now zero. -This speeds up reading output from sub-processes that produce a lot of -data. - -This variable may need to be non-zero only when running DOS programs -as Emacs subprocesses, which by now is not supported on modern -versions of MS-Windows. Set this variable to 50 if for some reason -you need the old behavior (and please report such situations to Emacs -developers). - -** New variable 'w32-multibyte-code-page'. -This variable holds the value of the multibyte code page used by the -system. It is usually zero, which indicates that 'w32-ansi-code-page' -is being used, except in Far Eastern locales. When this variable is -non-zero, Emacs at startup sets 'locale-coding-system' to the -corresponding encoding, instead of using 'w32-ansi-code-page'. - -** The default value of 'inhibit-compacting-font-caches' is t on MS-Windows. -Experience shows that compacting font caches causes more trouble on -MS-Windows than it helps. - -** Font lookup on MS-Windows was improved to support rare scripts. -To activate the improvement, run the new function -'w32-find-non-USB-fonts' once per Emacs session, or assign to the new -variable 'w32-non-USB-fonts' the list of scripts and the corresponding -fonts. See the documentation of this function and variable in the -Emacs manual for more details. - -** On NS the behavior of drag and drop can now be modified by use of -modifier keys in line with Apples guidelines. This makes the drag and -drop behavior more consistent, as previously the sending application -was able to 'set' modifiers without the knowledge of the user. - -** On NS multicolor font display is enabled again since it is also -implemented in Emacs on free operating systems via Cairo drawing. ++++ +** On MS-Windows, Emacs can now use the native image API to display images. +Emacs can now use the MS-Windows GDI+ library to load and display +images in JPEG, PNG, GIF and TIFF formats. This support is enabled +unless Emacs was configured '--without-native-image-api'. + +This feature is experimental, and needs to be turned on to be used. +To turn this on, set the variable 'w32-use-native-image-API' to a +non-nil value. Please report any bugs you find while using the native +image API via 'M-x report-emacs-bug'. ---------------------------------------------------------------------- diff --git a/etc/NEWS.27 b/etc/NEWS.27 new file mode 100644 index 00000000000..a056f5c1e82 --- /dev/null +++ b/etc/NEWS.27 @@ -0,0 +1,3206 @@ +GNU Emacs NEWS -- history of user-visible changes. + +Copyright (C) 2017-2020 Free Software Foundation, Inc. +See the end of the file for license conditions. + +Please send Emacs bug reports to 'bug-gnu-emacs@gnu.org'. +If possible, use 'M-x report-emacs-bug'. + +This file is about changes in Emacs version 27. + +See file HISTORY for a list of GNU Emacs versions and release dates. +See files NEWS.26, NEWS.25, ..., NEWS.18, and NEWS.1-17 for changes +in older Emacs versions. + +You can narrow news to a specific version by calling 'view-emacs-news' +with a prefix argument or by typing 'C-u C-h C-n'. + +Temporary note: ++++ indicates that all relevant manuals in doc/ have been updated. +--- means no change in the manuals is needed. +When you add a new item, use the appropriate mark if you are sure it +applies, and please also update docstrings as needed. + + +* Installation Changes in Emacs 27.1 + +--- +** Emacs now uses GMP, the GNU Multiple Precision library. +By default, if 'configure' does not find a suitable libgmp, it +arranges for the included mini-gmp library to be built and used. +The new configure option '--without-libgmp' uses mini-gmp even if a +suitable libgmp is available. + +** Emacs can now use HarfBuzz as its shaping engine. +The new configure option '--with-harfbuzz' adds support for the +HarfBuzz text shaping engine. It is on by default; use './configure +--without-harfbuzz' to build without it. The HarfBuzz text shaping is +available via new font backend drivers 'xfthb' and 'ftcrhb' for Xft +and Cairo drawings, respectively, and via the 'harfbuzz' backend on +MS-Windows. The HarfBuzz text shaping is preferred to the previously +supported ones, so the font backends that use older shaping engines +(FLT on GNU and Unix systems and Uniscribe on MS-Windows) are not +enabled by default; they can be enabled via the 'font-backend' frame +parameter or via X resources. + +** The new configure option '--with-json' adds native support for JSON. +This uses the Jansson library. The option is on by default; use +'./configure --with-json=no' to build without Jansson support. The +new JSON functions 'json-serialize', 'json-insert', +'json-parse-string', and 'json-parse-buffer' are typically much faster +than their Lisp counterparts from json.el. + +** The configure option '--with-cairo' is no longer experimental. +This builds Emacs with Cairo drawing, and supports built-in printing +when Emacs is built with GTK+. Some severe bugs in this build were +fixed, and we can therefore offer this to users without caveats. Note +that building with Cairo enabled results in using Pango instead of +libXft for font support, and that Pango 1.44 has removed support for +bitmapped fonts. + ++++ +** Emacs now uses a "portable dumper" instead of unexec. +This improves compatibility with memory allocation on modern systems, +and in particular better supports the Address Space Layout +Randomization (ASLR) feature, a security technique used by most modern +operating systems. + +When built with the portable dumping support (which is the default), +Emacs looks for the "emacs.pdmp" file, generated during the build, in +its data directory at startup, and loads the dumped state from there. +The new command-line argument '--dump-file=FILE' allows specifying a +non-default ".pdmp" file to load the state from; see the node +"(emacs) Initial Options" in the Emacs manual for more information. + +An Emacs started via a dump file can create a new dump file only if it +was invoked with the '-batch' option. (This is a temporary +limitation; we plan on lifting it in a future release.) + +Although the portable dumper has been tested, it may have a bug on +unusual platforms. If you require traditional unexec dumping you can +use the configure-time option '--with-dumping=unexec'; however, please +file a bug report describing the situation, as unexec dumping is +deprecated, and we plan on removing it in some future release. + +** The new configure option '--enable-checking=structs' attempts to +check that the portable dumper code has been updated to match the last +change to one of the data structures that it relies on. + +** The configure options '--enable-checking=conslist' and +'--enable-checking=xmallocoverrun' have been withdrawn. The former +made Emacs irredeemably slow, and the latter made it crash. Neither +option was useful with modern debugging tools such as AddressSanitizer. +(See "etc/DEBUG" for the details of using the modern replacements of the +removed configure options.) + +** Emacs no longer defaults to using ImageMagick to display images. +This is due to security and stability concerns with ImageMagick. To +override the default, use 'configure --with-imagemagick'. + +** Several configure options now accept an option-argument 'ifavailable'. +For example, './configure --with-xpm=ifavailable' now configures Emacs +to attempt to use libxpm but to continue building even if libxpm is +absent. The other affected options are '--with-gif', '--with-gnutls', +'--with-jpeg', '--with-png', and '--with-tiff'. + +** The 'etags' program now uses the C library's regular expression matcher. +If it's possible, 'etags' will use the regexp matcher from the +system's standard C library, otherwise it will be linked with a +compatible regex substitute. This lets developers maintain Emacs's +own regex code without having to also support other programs. The new +configure option '--without-included-regex' forces 'etags' to use the C +library's regex matcher even if the regex substitute ordinarily would +be used to work around compatibility problems. + +** Emacs has been ported to the '-fcheck-pointer-bounds' option of GCC. +This causes Emacs to check bounds of some arrays addressed by its +internal pointers, which can be helpful when debugging the Emacs +interpreter or modules that it uses. If your platform supports it you +can enable it when configuring, e.g., './configure CFLAGS="-g3 -O2 +-mmpx -fcheck-pointer-bounds"' on Intel MPX platforms. + +** Emacs now normally uses a C pointer type instead of a C integer +type to implement Lisp_Object, which is the fundamental machine word +type internal to the Emacs Lisp interpreter. This change aims to +catch typos and supports '-fcheck-pointer-bounds'. The configure +option '--enable-check-lisp-object-type' is therefore no longer as +useful and so is no longer enabled by default in developer builds, +to reduce differences between developer and production builds. + +** The distribution tarball now has test cases; 'make check' runs them. +This is intended mostly to help developers. + +** Emacs now requires GTK 2.24 and GTK 3.10 for the GTK 2 and GTK 3 +builds respectively. + +** New make target 'help' shows a summary of common make targets. + +** Emacs now builds with dynamic module support by default. +Pass '--without-modules' to 'configure' to disable dynamic module +support. + +** The ftx font backend driver is now obsolete and will be removed in +Emacs 28. + + +* Startup Changes in Emacs 27.1 + +** Emacs can now use the XDG convention for init files. +The 'XDG_CONFIG_HOME' environment variable (which defaults to +"~/.config") specifies the XDG configuration parent directory. Emacs +checks for "init.el" and other configuration files inside the "emacs" +subdirectory of 'XDG_CONFIG_HOME', i.e. "$XDG_CONFIG_HOME/emacs/init.el" + +However, Emacs will still initially look for init files in their +traditional locations if "~/.emacs.d" or "~/.emacs" exist, even if +"$XDG_CONFIG_HOME/emacs" also exists. This means that you must delete +or rename any existing "~/.emacs.d" and "~/.emacs" to enable use of +the XDG directory. + +If "~/.emacs.d" does not exist, and Emacs has decided to use it +(i.e. "$XDG_CONFIG_HOME/emacs" does not exist), Emacs will create it. +Emacs will never create "$XDG_CONFIG_HOME/emacs". + +Whichever directory Emacs decides to use, it will set +'user-emacs-directory' to point to it. + +** Emacs can now be configured using an early init file. +The file is called "early-init.el", in 'user-emacs-directory'. It is +loaded very early in the startup process: before graphical elements +such as the tool bar are initialized, and before the package manager +is initialized. The primary purpose is to allow customizing how the +package system is initialized given that initialization now happens +before loading the regular init file (see below). + +We recommend against putting any customizations in this file that +don't need to be set up before initializing installed add-on packages, +because the early init file is read too early into the startup +process, and some important parts of the Emacs session, such as +'window-system' and other GUI features, are not yet set up, which could +make some customization fail to work. + +** Installed packages are now activated *before* loading the init file. +As a result of this change, it is no longer necessary to call +'package-initialize' in your init file. + +Previously, a call to 'package-initialize' was automatically inserted +into the init file when Emacs was started. This call can now safely +be removed. Alternatively, if you want to ensure that your init file +is still compatible with earlier versions of Emacs, change it to: + +(when (< emacs-major-version 27) + (package-initialize)) + +However, if your init file changes the values of 'package-load-list' +or 'package-user-dir', or sets 'package-enable-at-startup' to nil then +it won't work right without some adjustment: +- You can move that code to the early init file (see above), so those + settings apply before Emacs tries to activate the packages. +- You can use the new 'package-quickstart' so activation of packages + does not need to pay attention to 'package-load-list' or + 'package-user-dir' any more. + +** Emacs now notifies systemd when startup finishes or shutdown begins. +Units that are ordered after 'emacs.service' will only be started +after Emacs has finished initialization and is ready for use. +(If your Emacs is installed in a non-standard location and you copied the +emacs.service file to e.g. "~/.config/systemd/user/", you will need to copy +the new version of the file again.) + + +* Changes in Emacs 27.1 + +** Emacs now supports Unicode Standard version 13.0. + +** Emacs now supports resizing and rotating images without ImageMagick. +All modern systems support this feature. (On GNU and Unix systems, +Cairo drawing or the XRender extension to X11 is required for this to +be available; the configure script will test for it and, if found, +enable scaling.) + +The new function 'image-transforms-p' can be used to test whether any +given frame supports these capabilities. + +** The Network Security Manager now allows more fine-grained control +of what checks to run via the 'network-security-protocol-checks' +user option. + +** TLS connections have their security tightened by default. +Most of the checks for outdated, believed-to-be-weak TLS algorithms +and ciphers are now switched on by default. (In addition, several new +TLS weaknesses are now warned about.) By default, the NSM will +flag connections using these weak algorithms and ask users whether to +allow them. To get the old behavior back (where certificates are +checked for validity, but no warnings about weak cryptography are +issued), you can either set 'network-security-protocol-checks' to nil, +or adjust the elements in that user option to only happen on the 'high' +security level (assuming you use the 'medium' level). + +** New user option 'nsm-trust-local-network'. +Allows skipping Network Security Manager checks for hosts on your +local subnet(s). It defaults to nil. Usually, there should be no +need to set this non-nil, and doing that risks opening your local +network connections to attacks. So be sure you know what you are +doing before changing the value. + +** Native GnuTLS connections can now use client certificates. +Previously, this support was only available when using the external +'gnutls-cli' or 'starttls' command. Call 'open-network-stream' with +':client-certificate t' to trigger looking up of per-server +certificates via 'auth-source'. + +** New user option 'network-stream-use-client-certificates'. +When non-nil, 'open-network-stream' performs lookups of client +certificates using 'auth-source' as if ':client-certificate t' were +specified if there is no explicit ':client-certificate' parameter. +Defaults to nil. + +** 'next/previous-multiframe-window' have been renamed. +The new names are as follows: + + 'next-multiframe-window' -> 'next-window-any-frame' + 'previous-multiframe-window' -> 'previous-window-any-frame' + +The old function names are maintained as aliases for backward +compatibility. + +** emacsclient +*** emacsclient now supports the 'EMACS_SOCKET_NAME' environment variable. +The command-line argument '--socket-name' overrides it. +(The same behavior as for the pre-existing 'EMACS_SERVER_FILE' variable.) + +*** Emacs and emacsclient now default to "$XDG_RUNTIME_DIR/emacs". +This is used as the directory for client/server sockets, if Emacs is +running on a platform or environment that sets the 'XDG_RUNTIME_DIR' +environment variable to indicate where session sockets should go. +To get the old, less-secure behavior, you can set the +'EMACS_SOCKET_NAME' environment variable to an appropriate value. + +*** When run by root, emacsclient no longer connects to non-root sockets. +(Instead you can use Tramp methods to run root commands in a non-root Emacs.) + +** 'xft-ignore-color-fonts' now ignores even more color fonts. +There are color fonts that managed to bypass the existing checks, +causing XFT crashes, they are now filtered out. Setting +'xft-ignore-color-fonts' to nil removes those checks, which might +require setting 'face-ignored-fonts' to filter out problematic fonts. +Known problematic fonts are "Noto Color Emoji" and "Emoji One". + +** The GTK+ font chooser now respects 'face-ignored-fonts'. +When using 'menu-set-font' under GTK3, the available fonts are now +matched against 'face-ignored-fonts'. + +** The GTK+ font chooser now remembers the previously selected settings. +It now remembers the name, size, style, etc. + +** New user option 'what-cursor-show-names'. +When non-nil, 'what-cursor-position' will show the name of the character +in addition to the decimal/hex/octal representation. Default nil. + +** New function 'network-lookup-address-info'. +This does IPv4 and/or IPv6 address lookups on hostnames. + +** 'network-interface-list' can now return IPv4 and IPv6 addresses. +IPv4 and IPv6 addresses are now returned by default if available, +optionally including netmask/broadcast address information. + +** Control of the threshold for using the 'distant-foreground' color. +The threshold for color distance below which the 'distant-foreground' +color of the face will be used instead of the foreground color can now +be controlled via the new variable 'face-near-same-color-threshold'. +The default value is 30000, as the previously hard-coded threshold. + +** The function 'read-passwd' uses "*" as default character to hide passwords. + +** The function 'read-answer' now accepts not only single character +answers, but also function keys like 'F1', character events such as +'C-M-h', and control characters like 'C-h'. + +** Lexical binding is now used by default when evaluating interactive Elisp. +More specifically, 'lexical-binding' is now used by default for 'M-:' +and '--eval' (including in evaluations invoked from 'emacsclient' via +its '--eval' command-line option), as well as in +'lisp-interaction-mode' and 'ielm-mode', used in the "*scratch*" and +"*ielm*" buffers. + +We envision that most Lisp code is already either written with +lexical-binding in mind, or will work unchanged under +lexical-binding. If, for some reason, your code used in 'M-:' or +'--eval' doesn't work as result of this change, either modify the code +to work with lexical binding, or wrap it in an extra level of 'eval'. +For example, --eval "FORM" becomes --eval "(eval 'FORM)" (note the extra +quote in 'FORM). + +** The new user option 'tooltip-resize-echo-area' avoids truncating +tooltip text on GUI frames when tooltips are displayed in the echo +area. Instead, it resizes the echo area as needed to accommodate the +full tool-tip text. + +** Show mode line tooltips only if the corresponding action applies. +Customize the user option 'mode-line-default-help-echo' to restore the +old behavior where the tooltip text is also shown when the +corresponding action does not apply. + +** New hook 'server-after-make-frame-hook'. +This hook is a convenient place to perform initializations in daemon +mode which require GUI features to be available. One example is +restoration of the previous session using the desktop.el package: put +the call to 'desktop-read' in this hook, if you want the GUI settings +to be restored, or if desktop.el needs to interact with you during +restoration of the session. + +** The functions 'set-frame-height' and 'set-frame-width' are now +commands, and will set the currently selected frame to the height/ +width specified by the numeric prefix. + +** New function 'logcount' calculates an integer's Hamming weight. + +** New function 'libxml-available-p'. +This function returns non-nil if libxml support is both compiled in +and available at run time. Lisp programs should use this function to +detect built-in libxml support, instead of testing for that +indirectly, e.g., by checking that functions like +'libxml-parse-html-region' return nil. + +** 'libxml-parse-xml-region' and 'libxml-parse-html-region' take +a parameter that's called DISCARD-COMMENTS, but it really only +discards the top-level comment. Therefore this parameter is now +obsolete, and the new utility function 'xml-remove-comments' can be +used to remove comments before calling the libxml functions to parse +the data. + +** A new DOM (the XML/HTML document structure returned by functions +such as 'libxml-parse-html-region') traversal function has been added: +'dom-search', which takes a DOM and a predicate and returns all nodes +that match. + +** New function 'fill-polish-nobreak-p', to be used in 'fill-nobreak-predicate'. +It blocks line breaking after a one-letter word, also in the case when +this word is preceded by a non-space, but non-alphanumeric character. + +** The limit on repetitions in regexps has been raised to 2^16-1. +It was previously limited to 2^15-1. For example, the following +regular expression was previously invalid, but is now accepted: + + x\{32768\} + +** The German prefix and postfix input methods now support Capital sharp S. + +** New input methods 'hawaiian-postfix' and 'hawaiian-prefix'. + +** New input methods 'georgian-qwerty' and 'georgian-nuskhuri'. + +** New input methods for several variants of the Sami language. +The Sami input methods include: 'norwegian-sami-prefix', +'bergsland-hasselbrink-sami-prefix', 'southern-sami-prefix', +'ume-sami-prefix', 'northern-sami-prefix', 'inari-sami-prefix', +'skolt-sami-prefix', and 'kildin-sami-prefix'. + +** Japanese environments use UTF-8 by default. +In Japanese environments that do not specify encodings and are not +based on MS-Windows, the default encoding is now utf-8 instead of +japanese-iso-8bit. + +** New function 'exec-path'. +This function by default returns the value of the corresponding +user option, but can optionally return the equivalent of 'exec-path' +from a remote host. + +** The function 'executable-find' supports an optional argument REMOTE. +This triggers searching for the program on the remote host as indicated by +'default-directory'. + +** New user option 'auto-save-no-message'. +When set to t, no message will be shown when auto-saving (default +value: nil). + +** The value of 'make-cursor-line-fully-visible' can now be a function. +In addition to nil or non-nil, the value can now be a predicate +function. Follow mode uses this to control scrolling of its windows +when the last screen line in a window is not fully visible. + +** New variable 'emacs-repository-branch'. +It reports the git branch from which Emacs was built. + +** New user option 'switch-to-buffer-obey-display-actions'. +When non-nil, 'switch-to-buffer' uses 'pop-to-buffer-same-window' that +respects display actions specified by 'display-buffer-alist' and +'display-buffer-overriding-action'. + +** The user option 'switch-to-visible-buffer' is now obsolete. +Customize 'switch-to-prev-buffer-skip' instead. + +** New user option 'switch-to-prev-buffer-skip'. +This user option allows specifying the set of buffers that may be +shown by 'switch-to-prev-buffer' and 'switch-to-next-buffer' more +stringently than the now obsolete 'switch-to-visible-buffer'. + +** New 'flex' completion style. +An implementation of popular "flex/fuzzy/scatter" completion which +matches strings where the pattern appears as a subsequence. Put +simply, makes "foo" complete to both "barfoo" and "frodo". Add 'flex' +to 'completion-styles' or 'completion-category-overrides' to use it. + +** The 'completion-common-part' face is now visible by default. + +** New face attribute ':extend' to control face extension at EOL. +The new face attribute ':extend' controls whether to use the face for +displaying the empty space beyond end of line (EOL) till the edge of +the window. By default, this attribute is non-nil only for a small +number of faces, notably, 'region'; any other face that crosses end of +line will not affect the display of the empty space at EOL. This is +to make Emacs behave more like other GUI applications with respect to +displaying faces that cross line boundaries. + +This attribute behaves specially when theme definitions are applied: +if the theme doesn't specify an explicit value of this attribute for a +face, the value from the original face definition is inherited. +Consequently, a theme generally shouldn't specify this attribute +unless it has a good reason to do so. + +** Connection-local variables +*** Connection-local variables are applied by default like file-local +and directory-local variables. + +*** The macro 'with-connection-local-variables' has been renamed from +'with-connection-local-profiles'. No argument PROFILES needed any longer. + +** New user option 'next-error-verbose' controls when 'next-error' +outputs a message about the error locus. + +** New user option 'grep-search-path' defines the directories searched for +grep hits (this used to be controlled by 'compilation-search-path'). + +** New user option 'emacs-lisp-compilation-search-path' defines the +directories searched for byte-compiler error messages (this used to +be controlled by 'compilation-search-path'). + +** Multicolor fonts such as "Noto Color Emoji" can be displayed on +Emacs configured with Cairo drawing and linked with cairo >= 1.16.0. + +** Emacs now optionally displays a fill column indicator. +This is similar to what 'fill-column-indicator' package provides, but +much faster and compatible with 'show-trailing-whitespace'. + +Customize the buffer-local user options 'display-fill-column-indicator' +and 'display-fill-column-indicator-character' to activate the +indicator. + +The indicator is not displayed at all in minibuffer windows and +in tooltips, as it is not useful there. + +There are 2 new buffer local variables and 1 face to customize this +mode, they are described in the manual "(emacs) Display". + +** 'progress-reporter-update' now accepts an optional suffix string to display. + +** New user option 'xref-file-name-display' controls the display of +file names in xref buffers. + +** New user option 'byte-count-to-string-function'. +It is used for displaying file sizes and disk space in some cases. + +** Emacs now interprets RGB triplets like HTML, SVG, and CSS do. +The X convention previously used differed slightly, particularly for +RGB triplets with a single hexadecimal digit per component. + +** The toolbar now shows the equivalent key binding in its tooltips. + +** The File menu-bar menu was re-arranged. +Print menu items moved to submenu, and also added the new entries for tabs. + +** 'scroll-lock-mode' is now bound to the 'Scroll_Lock' key globally. +Note that this key binding will not work on MS-Windows systems if +'w32-scroll-lock-modifier' is non-nil. + +** 'global-set-key', called interactively, now no longer downcases a +key binding with an upper case letter - if you can type it, you can +bind it. + +** 'read-from-minibuffer' now works with buffer-local history variables. +The HIST argument of 'read-from-minibuffer' now works correctly with +buffer-local variables. This means that different buffers can have +their own separated input history list if desired. + +** 'backup-by-copying-when-privileged-mismatch' applies to file gid, too. +In addition to checking the file owner uid, Emacs also checks that the +group gid is not greater than 'backup-by-copying-when-privileged-mismatch'; +if so, 'backup-by-copying-when-mismatch' will be forced on. + + +* Editing Changes in Emacs 27.1 + +** When asked to visit a large file, Emacs now offers to visit it literally. +Previously, Emacs would only ask for confirmation before visiting +large files. Now it also offers a third alternative: to visit the +file literally, as in 'find-file-literally', which speeds up +navigation and editing of large files. + +** 'zap-to-char' now uses the history of characters you used to zap to. +'zap-to-char' uses the new 'read-char-from-minibuffer' function to allow +navigating through the history of characters that have been input. +This is mostly useful for characters that have complex input methods +where inputting the character again may involve many keystrokes. + +** 'save-some-buffers' now has a new action in the prompt: 'C-f' will +exit the command and switch to the buffer currently being asked about. + +** More commands support noncontiguous rectangular regions, namely +'upcase-dwim', 'downcase-dwim', 'capitalize-dwim', 'capitalize-region', +'upcase-initials-region', 'replace-string', 'replace-regexp', and +'delimit-columns-region'. + +** The new 'amalgamating-undo-limit' variable can be used to control +how many changes should be amalgamated when using the 'undo' command. + +** The 'newline-and-indent' command (commonly bound to 'RET' in many +modes) now takes an optional numeric argument to specify how many +times is should insert newlines (and indent). + +** New command 'make-empty-file'. + +** New variable 'x-wait-for-event-timeout'. +This controls how long Emacs will wait for updates to the graphical +state to take effect (making a frame visible, for example). + +** New user option 'electric-quote-replace-double'. +This option controls whether '"' is replaced in 'electric-quote-mode', +in addition to other quote characters. If non-nil, ASCII double-quote +characters that quote text "like this" are replaced by double +typographic quotes, “like this”, in text modes, and in comments in +non-text modes. + +** New user option 'flyspell-case-fold-duplications'. +This option controls whether Flyspell mode considers consecutive words +to be duplicates if they are not in the same case. If non-nil, the +default, words are considered to be duplicates even if their letters' +case does not match. + +** 'write-abbrev-file' now includes special properties. +'write-abbrev-file' now writes special properties like ':case-fixed' +for abbrevs that have them. + +** 'write-abbrev-file' skips empty tables. +'write-abbrev-file' now skips inserting a 'define-abbrev-table' form for +tables which do not have any non-system abbrevs to save. + +** The new functions and commands 'text-property-search-forward' and +'text-property-search-backward' have been added. These provide an +interface that's more like functions like 'search-forward'. + +** 'add-dir-local-variable' now uses dotted pair notation syntax to +write alists of variables to ".dir-locals.el". This is the same +syntax that you can see in the example of a ".dir-locals.el" file in +the node "(emacs) Directory Variables" of the user manual. + +** Network connections using 'local' can now use IPv6. +'make-network-process' now uses the correct loopback address when +asked to use ':host 'local' and ':family 'ipv6'. + +** The new function 'replace-region-contents' replaces the current +region using a given replacement-function in a non-destructive manner +(in terms of 'replace-buffer-contents'). + +** The command 'replace-buffer-contents' now has two optional +arguments mitigating performance issues when operating on huge +buffers. + +** Dragging 'C-M-mouse-1' now marks rectangular regions. + +** The command 'delete-indentation' now operates on the active region. +If the region is active, the command joins all the lines in the +region. When there's no active region, the command works on the +current and the previous or the next line, as before. + +** You can now change the font size with the mouse wheel. +Scrolling the mouse wheel with the Ctrl key pressed will now act the +same as the 'C-x C-+' and 'C-x C--' commands. + + +* Changes in Specialized Modes and Packages in Emacs 27.1 + +** New HTML mode skeleton 'html-id-anchor'. +This new command (which inserts an <a id="foo">_</a> skeleton) is +bound to 'C-c C-c #'. + +** New command 'font-lock-refontify'. +This is an interactive convenience function to be used when developing +font locking for a mode. It recomputes the font locking data and then +re-fontifies the buffer. + +** Font Lock is smarter about fontifying unterminated strings and comments. +When you type a quote that starts a string, or a comment delimiter +that starts a comment, font-lock will not immediately refontify the +following characters in 'font-lock-string-face' or +'font-lock-comment-face'. Instead, it will delay the fontification +beyond the current line to give you a chance to close the string or +comment. This is controlled by the new user option +'jit-lock-antiblink-grace', which specifies the delay in seconds. The +default is 2 seconds; set to nil to get back the old behavior. + +** The 'C' command in 'tar-mode' will now preserve the timestamp of +the extracted file if the new user option 'tar-copy-preserve-time' is +non-nil. + +** 'autoconf-mode' is now used instead of 'm4-mode' for the +"acinclude.m4" / "aclocal.m4" / "acsite.m4" files. + +** On GNU/Linux, 'M-x battery' will now list all batteries, no matter +what they're named, and the 'battery-linux-sysfs-regexp' variable has +been removed. + +** The 'list-processes' command now includes port numbers in the +network connection information (in addition to the host name). + +** The 'cl' package is now officially deprecated in favor of 'cl-lib'. + +** desktop + +*** When called interactively with a prefix arg 'C-u', 'desktop-read' +now prompts the user for the directory containing the desktop file. + +** display-line-numbers-mode + +*** New faces 'line-number-major-tick' and 'line-number-minor-tick', +and user options 'display-line-numbers-major-tick' and +'display-line-numbers-minor-tick' can be used to highlight the line +numbers of lines multiple of certain numbers. + +*** New variable 'display-line-numbers-offset', when non-zero, adds +an offset to absolute line numbers. + +** winner + +*** A new user option, 'winner-boring-buffers-regexp', has been added. + +** table + +*** 'table-generate-source' now supports wiki and mediawiki. +This command can now output wiki and mediawiki format tables. + +** telnet-mode + +*** Reverting a buffer in 'telnet-mode' will restart a closed connection. + +** goto-addr + +*** A way to more conveniently specify what URI address schemes should +be ignored has been added via the 'goto-address-uri-schemes-ignored' +variable. + +** tex-mode + +*** 'latex-noindent-commands' controls indentation of certain commands. +You can use this new user option to control indentation of arguments of +\emph, \footnote, and similar commands. + +** byte compiler + +*** 'byte-compile-dynamic' is now obsolete. +This is because on the one hand it suffers from misbehavior in corner +cases that have plagued it for years, and on the other hand experience +indicates that it doesn't bring any measurable benefit. + +*** The 'g' keystroke in "*Compile-Log*" buffers has been bound to a +new command that will recompile the file previously compiled with 'M-x +byte-compile-file' and the like. + +** compile.el + +*** In 'compilation-error-regexp-alist', 'line' (and 'end-line') can +be functions. + +*** 'compilation-context-lines' can now take the value t; this is like +nil, but instead of scrolling the current line to the top of the +screen when there is no left fringe, it inserts a visible arrow before +column zero. + +*** The new 'compilation-transform-file-match-alist' user option can +be used to transform file name matches compilation output, and remove +known false positives being recognized as warnings/errors. + +** cl-lib.el + +*** 'cl-defstruct' has a new ':noinline' argument to prevent inlining +its functions. + +*** 'cl-defstruct' slots accept a ':documentation' property. + +*** 'cl-values-list' will now signal an error if its argument isn't a list. + +** doc-view.el + +*** New commands 'doc-view-presentation' and 'doc-view-fit-window-to-page'. + +*** Added support for password-protected PDF files. + +*** A new user option 'doc-view-pdftotext-program-args' has been added +to allow controlling how the conversion to text is done. + +*** The prefix key 's' was changed to 'c' for slicing commands +to avoid conflicts with 'image-mode' key 's'. The new key 'c' still +has good mnemonics of "cut", "clip", "crop". + +** Ido + +*** New user option 'ido-big-directories' to mark directories whose +names match certain regular expressions as big. Ido won't attempt to +list the contents of such directories when completing file names. + +** Minibuffer + +*** New user option 'minibuffer-beginning-of-buffer-movement'. +This option allows control of how the 'M-<' command works in +the minibuffer. If non-nil, point will move to the end of the prompt +(if point is after the end of the prompt). The default is nil, which +preserves the original behavior of 'M-<' moving to the beginning of +the prompt. + +*** When the minibuffer is active, echo-area messages are displayed at +the end of the minibuffer instead of hiding the minibuffer by the echo +area display. The new user option 'minibuffer-message-clear-timeout' +controls how messages displayed in this situation are removed from the +minibuffer. To revert to previous behavior, where echo-area messages +temporarily overwrote the minibuffer contents until the user typed +something, set 'set-message-function' and 'clear-message-function' to +nil. + +*** Minibuffer now uses 'minibuffer-message' to display error messages +at the end of the active minibuffer. To disable this, remove +'minibuffer-error-initialize' from 'minibuffer-setup-hook'. + +*** 'y-or-n-p' now uses the minibuffer to read 'y' or 'n' answer. + +*** Some commands that previously used 'read-char-choice' now read +a character using the minibuffer by 'read-char-from-minibuffer'. + +** map.el + +*** Now also understands plists. +*** Now defined via generic functions that can be extended via 'cl-defmethod'. +*** Deprecate the 'map-put' macro in favor of a new 'map-put!' function. +*** 'map-contains-key' now returns a boolean rather than the key. +*** Deprecate the 'testfn' args of 'map-elt' and 'map-contains-key'. +*** New generic function 'map-insert'. +*** The 'type' arg can be a list '(hash-table :key1 VAL1 :key2 VAL2 ...)'. + +** seq.el +New convenience functions 'seq-first' and 'seq-rest' give easy access +to respectively the first and all but the first elements of sequences. + +The new predicate function 'seq-contains-p' should be used instead of +the now obsolete 'seq-contains'. + +** Follow mode +In the current follow group of windows, "ghost" cursors are no longer +displayed in the non-selected follow windows. To get the old behavior +back, customize 'follow-hide-ghost-cursors' to nil. + +** New variable 'warning-fill-column' for 'display-warning'. + +** Windmove + +*** 'windmove-create-window' when non-nil makes a new window. +This happens upon moving off the edge of the frame. + +*** Windmove supports directional window display and selection. +The new command 'windmove-display-default-keybindings' binds default +keys with provided modifiers (by default, Shift-Meta) to the commands +that display the next buffer in the window at the specified direction. +This is like 'windmove-default-keybindings' that binds keys to commands +that select the window in the specified direction, but additionally it +displays the buffer from the next command in that window. For example, +'S-M-right C-h i' displays the "*Info*" buffer in the right window, +creating the window if necessary. A special key can be customized to +display the buffer in the same window, for example, 'S-M-0 C-h e' +displays the "*Messages*" buffer in the same window. 'S-M-t C-h r' +displays the Emacs manual in a new tab. + +*** Windmove also supports directional window deletion. +The new command 'windmove-delete-default-keybindings' binds default +keys with provided prefix (by default, 'C-x') and modifiers (by default, +'Shift') to the commands that delete the window in the specified +direction. For example, 'C-x S-down' deletes the window below. +With a prefix arg 'C-u', also kills the buffer in that window. +With 'M-0', deletes the selected window and selects the window +that was in the specified direction. + +*** New command 'windmove-swap-states-in-direction' binds default keys +to the commands that swap the states of the selected window with the +window in the specified direction. + +*** Windmove code no longer used is now obsolete. +That includes the user option 'windmove-window-distance-delta' and the +functions 'windmove-coord-add', 'windmove-constrain-to-range', +'windmove-constrain-around-range', 'windmove-frame-edges', +'windmove-constrain-loc-for-movement', 'windmove-wrap-loc-for-movement', +'windmove-reference-loc' and 'windmove-other-window-loc'. + +** Octave mode +The mode is automatically enabled in files that start with the +'function' keyword. + +** project.el + +*** New commands 'project-search' and 'project-query-replace-regexp'. + +*** New user option 'project-read-file-name-function'. + +** Etags + +*** 'next-file' is now an obsolete alias of 'tags-next-file'. + +*** 'tags-loop-revert-buffers' is an obsolete alias of +'fileloop-revert-buffers'. + +*** The 'tags-loop-continue' function along with the +'tags-loop-operate' and 'tags-loop-scan' variables are now obsolete; +use the new 'fileloop-initialize' and 'fileloop-continue' functions +instead. + +*** etags is now able to read Zstandard-compressed files. + +** bibtex + +*** New commands 'bibtex-next-entry' and 'bibtex-previous-entry'. +In 'bibtex-mode-map', 'forward-paragraph' and 'backward-paragraph' are +remapped to these, respectively. + +** Dired + +*** New command 'dired-create-empty-file'. + +*** New command 'dired-number-of-marked-files'. +It is by default bound to '* N'. + +*** The marking commands now report how many files were marked by the +command itself, not how many files are marked in total. + +*** The new user option 'dired-create-destination-dirs' controls whether +'dired-do-copy' and 'dired-rename-file' should create non-existent +directories in the destination. + +*** 'dired-dwim-target' can be customized to prefer either the next window, +or one of the most recently visited windows with a Dired buffer. + +*** When the new user option 'dired-vc-rename-file' is non-nil, +Dired performs file renaming using underlying version control system. + +*** Zstandard compression is now supported for 'dired-do-compress' and +'dired-do-compress-to'. + +*** On systems that support suid/guid files, Dired now fontifies the +permissions of such files with a special face 'dired-set-id'. + +*** A new face, 'dired-special', is used to highlight sockets, named +pipes, block devices and character devices. + +** Find-Dired + +*** New user option 'find-dired-refine-function'. +The default value is 'find-dired-sort-by-filename'. + +*** New sorting options for the user option 'find-ls-option'. + +** Change Logs and VC + +*** New user option 'vc-tor'. +When non-nil, this user option causes the VC commands to communicate +with the repository via Tor's proxy, using the 'torsocks' wrapper +script. The default is nil. + +*** New command 'log-edit-generate-changelog-from-diff', bound to 'C-c C-w'. +This generates ChangeLog entries from the VC fileset diff. + +*** Recording ChangeLog entries doesn't require an actual file. +If a ChangeLog file doesn't exist, and if the new user option +'add-log-dont-create-changelog-file' is non-nil (which is the +default), commands such as 'C-x 4 a' will add log entries to a +suitable named temporary buffer. (An existing ChangeLog file will +still be used if it exists.) Set the user option to nil to get the +previous behavior of always creating a buffer that visits a ChangeLog +file. + +*** The new 'd' command ('vc-dir-clean-files') in 'vc-dir-mode' +buffers will delete the marked files (or if no files are marked, the +file under point). This command does not notify the VC backend, and +is mostly useful for unregistered files. + +*** 'vc-dir-ignore' now takes a prefix argument to ignore all marked files. + +*** New user option 'vc-git-grep-template'. +This new user option allows customizing the default arguments passed to +'git-grep' when 'vc-git-grep' is used. + +*** Command 'vc-git-stash' now respects marks in the "*vc-dir*" buffer. +When some files are marked, only those are stashed. +When no files are marked, all modified files are stashed, as before. + +*** 'vc-dir' now shows a button allowing you to hide the stash list. +Controlled by user option 'vc-git-show-stash'. Default t means show +the entire list as before. An integer value limits the list length +(but still allows you to show the entire list via the button). + +*** 'vc-git-stash' is now bound to 'C' in the stash headers. + +-- +*** Some stash keybindings are now available in the stash button. +'vc-git-stash' and 'vc-git-stash-snapshot' can now be run using 'C' +and 'S' respectively, including when there are no stashes. + +*** The new hook 'vc-retrieve-tag-hook' runs after retrieving a tag. + +*** 'vc-hg' now invokes 'smerge-mode' when visiting files. +Code that attempted to invoke 'smerge-mode' when visiting an Hg file +with conflicts existed in earlier versions of Emacs, but incorrectly +never detected a conflict due to invalid assumptions about cached +values. + +*** The Hg (Mercurial) back-end now supports 'vc-region-history'. +The 'C-x v h' command now works in buffers that visit files controlled +by Hg. + +*** The Hg (Mercurial) back-end now prompts for revision to merge when +you invoke 'C-x v m' ('vc-merge'). + +*** The Hg (Mercurial) back-end now uses tags, branches and bookmarks +instead of revision numbers as completion candidates when it prompts +for a revision. + +*** New user option 'vc-hg-revert-switches'. +It specifies switches to pass to Hg's 'revert' command. + +*** 'C-u C-x v D' ('vc-root-version-diff') prompts for two revisions +and compares their entire trees. + +*** 'C-x v M D' ('vc-diff-mergebase') and 'C-x v M L' ('vc-log-mergebase') +print diffs and logs between the merge base (common ancestor) of two +given revisions. + +*** New command 'vc-log-search' asks for a pattern, searches it +in the revision log, and displays matched log entries in the +log buffer. For example, 'M-x vc-log-search RET bug#36644 RET' +displays all entries whose log messages match the bug number. +With a prefix argument asks for a command, so for example, +'C-u M-x vc-log-search RET git log -1 f302475 RET' will display +just one log entry found by its revision number. + +*** It is now possible to display a specific revision given by its ID. +If you invoke 'C-x v L' ('vc-print-root-log') with a numeric argument +of 1, as in 'C-1 C-x v L' or 'C-u 1 C-x v L', it asks for a revision +ID, and shows its log entry together with the diffs introduced by the +revision's commit. (For some less capable VCSes, only the log entry +is shown.) + +*** New user option 'vc-find-revision-no-save'. +With non-nil, 'vc-find-revision' doesn't write the created buffer to file. + +*** 'C-x v =' can now mimic Magit's diff format. +Set the new user option 'diff-font-lock-prettify' to t for that, see +below under "Diff mode". + +*** The 'diff' function arguments OLD and NEW may each be a buffer +rather than a file, in non-interactive calls. This change was made in +Emacs 24.1, but wasn't documented until now. + +*** New command 'diff-buffers' interactively diffs two buffers. + +** Diff mode + +*** Hunks are now automatically refined by font-lock. +To disable refinement, set the new user option 'diff-refine' to nil. +To get back the old behavior where hunks are refined as you navigate +through a diff, set 'diff-refine' to the symbol 'navigate'. + +*** 'diff-auto-refine-mode' is deprecated in favor of 'diff-refine'. +It is no longer enabled by default and binding it no longer has any +effect. + +*** Better syntax highlighting of Diff hunks. +Fragments of source in Diff hunks are now by default highlighted +according to the appropriate major mode. Customize the new user +option 'diff-font-lock-syntax' to nil to disable this. + +*** File headers can be shortened, mimicking Magit's diff format. +To enable it, set the new user option 'diff-font-lock-prettify' to t. +On GUI frames, this option also displays the insertion and deletion +indicators on the left fringe. + +*** Prefix arg of 'diff-goto-source' means jump to the old revision +of the file under version control if point is on an old changed line, +or to the new revision of the file otherwise. + +** Texinfo + +*** New function for inserting '@pxref', '@xref', or '@ref' commands. +The function 'texinfo-insert-dwim-@ref', bound to 'C-c C-c r' by +default, inserts one of three types of references based on the text +surrounding point, namely '@pxref' near a parenthesis, '@xref' at the +start of a sentence or at '(point-min)', else '@ref'. + +** Browse-url + +*** The function 'browse-url-emacs' can now visit a URL in selected window. +It now treats the optional 2nd argument to mean that the URL should be +shown in the currently selected window. + +*** A new function, 'browse-url-add-buttons' can be used to add clickable +links to most ordinary special-mode buffers that display text that +have URLs embedded. 'browse-url-button-regexp' controls what's +considered a button. + +*** New user option 'browse-url-secondary-browser-function'. +It can be set to a function that invokes an alternative browser. + +** Comint + +*** 'send-invisible' is now an obsolete alias for 'comint-send-invisible'. +Also, 'shell-strip-ctrl-m' is declared obsolete. + +*** 'C-c .' ('comint-insert-previous-argument') no longer interprets '&'. +This feature caused problems when '&&' was present in the previous +command. Since this command emulates 'M-.' in Bash and zsh, neither +of which treats '&' specially, the feature was removed for +compatibility with these shells. + +*** 'comint-insert-previous-argument' can now count arguments from the end. +By default, invoking 'C-c .' with a numeric argument N would copy the +Nth argument, counting from the first one. But if the new user option +'comint-insert-previous-argument-from-end' is non-nil, it will copy +the Nth argument counting from the last one. Thus 'C-c .' can now +better emulate 'M-.' in both Bash and zsh, since the former counts +from the beginning of the arguments, while the latter counts from the +end. + +*** 'comint-run' can now accept a list of switches to pass to the program. +'C-u M-x comint-run' will prompt for the switches interactively. + +*** Abnormal hook 'comint-password-function' has been added. +This hook permits a derived mode to supply a password for the +underlying command interpreter without prompting the user. For +example, in 'sql-mode', the password for connecting to the database may +be stored in the connection wallet and may be passed on the command +line to start the SQL interpreter. This is a potential security flaw +that could expose user's database passwords on the command line +through the use of a process list (Bug#8427). With this hook, it is +possible to not pass the password on the command line and wait for the +program to prompt for the password. When it does so, the password can +be supplied to the SQL interpreter without involving the user just as +if it had been supplied on the command line. + +** SQL + +*** SQL Indent Minor Mode +SQL Mode now supports the ELPA 'sql-indent' package for assisting +sophisticated SQL indenting rules. Note, however, that SQL is not +like other programming languages like C, Java, or Python where code is +sparse and rules for formatting are fairly well established. Instead +SQL is more like COBOL (from which it came) and code tends to be very +dense and line ending decisions driven by syntax and line length +considerations to make readable code. Experienced SQL developers may +prefer to rely upon existing Emacs facilities for formatting code but +the 'sql-indent' package provides facilities to aid more casual SQL +developers layout queries and complex expressions. + +**** 'sql-use-indent-support' (default t) enables SQL indention support. +The 'sql-indent' package from ELPA must be installed to get the +indentation support in 'sql-mode' and 'sql-interactive-mode'. + +**** 'sql-mode-hook' and 'sql-interactive-mode-hook' changed. +Both hook variables have had 'sql-indent-enable' added to their +default values. If you have existing customizations to these +variables, you should make sure that the new default entry is +included. + +*** Connection Wallet +Database passwords can now by stored in NETRC or JSON data files that +may optionally be encrypted. When establishing an interactive session +with the database via 'sql-connect' or a product specific function, +like 'sql-mysql' or 'sql-postgres', the password wallet will be +searched for the password. The 'sql-product', 'sql-server', +'sql-database', and the 'sql-username' will be used to identify the +appropriate authorization. This eliminates the discouraged practice of +embedding database passwords in your Emacs initialization. + +See the 'auth-source' module for complete documentation on the file +formats. By default, the wallet file is expected to be in the +'user-emacs-directory', named "sql-wallet" or ".sql-wallet", with +".json" (JSON) or no (NETRC) suffix. Both file formats can optionally +be encrypted with GPG by adding an additional ".gpg" suffix. + +** Term + +*** 'term-read-noecho' is now obsolete, use 'read-passwd' instead. + +*** 'serial-term' now takes an optional parameter to leave the +emulator in line mode. + +** Flymake + +*** The variable 'flymake-diagnostic-types-alist' is obsolete. +You should instead set properties on known diagnostic symbols, like +':error' and ':warning', as demonstrated in the Flymake manual. + +*** New user option 'flymake-start-on-save-buffer'. +Control whether Flymake starts checking the buffer on save. + +*** Flymake and backend functions may exchange hints about buffer changes. +This enables more efficient backends. See the docstring of +'flymake-diagnostic-functions' or the Flymake manual for details. + +*** 'flymake-start-syntax-check-on-newline' is now obsolete, +use 'post-self-insert-hook' to check on newline. + +** Ruby + +*** The Rubocop Flymake diagnostic function will only run Lint cops if +it can't find the config file. + +*** Rubocop is called with 'bundle exec' if Gemfile mentions it. + +*** New command 'ruby-find-library-file' bound to 'C-c C-f'. + +** Package + +*** Warn if "footer line" is missing, but still install package. +package.el used to refuse to install a package without the so-called +"footer line", which appears at the very end of the file: + +;;; FILENAME ends here + +package.el will now install packages without this line, but it will +issue a warning. To avoid this warning, packages should keep the +"footer line". + +Note that versions of Emacs older than 27.1 will not only refuse to +install packages without such a line -- they will be unable to parse +package data. It is therefore recommended to keep this line. + +*** Change of 'package-check-signature' for packages with multiple sigs. +In previous Emacsen, t checked that all signatures are valid. +Now t only checks that at least one signature is valid and the new 'all' +value needs to be used if you want to enforce that all signatures +are valid. This only affects packages with multiple signatures. + +*** The meaning of 'allow-unsigned' in 'package-check-signature' has +changed slightly: If a usable OpenPGP configuration can't be found +(for instance, if gpg isn't installed), it now has the same meaning as +nil. + +*** New function 'package-get-version' lets packages query their own version. +Example use in auctex.el: '(defconst auctex-version (package-get-version))' + +*** New 'package-quickstart' feature. +When 'package-quickstart' is non-nil, package.el precomputes a big +autoloads file so that activation of packages can be done much faster, +which can speed up your startup significantly. +It also causes user options like 'package-user-dir' and +'package-load-list' to be consulted when 'package-quickstart-refresh' +is run rather than at startup so you don't need to set them in your +early init file. + +*** New function 'package-activate-all'. + +*** New functions for filtering packages list. +A new function has been added which allows users to filter the +packages list by name: 'package-menu-filter-by-name'. By default, it +is bound to '/ n'. Additionally, the function +'package-menu-filter-by-keyword' has been renamed from +'package-menu-filter'. Its keybinding has also been changed to '/ k' +(from 'f'). To clear any of the two filters, the user can now call +the 'package-menu-clear-filter' function, bound to '/ /' by default. + +*** Imenu support has been added to 'package-menu-mode'. + +*** The package list can now be sorted by version or description. + +*** In Package Menu, 'g' now updates package data from archives. +Previously, 'g' invoked 'tabulated-list-revert' which did not update +the cached archive data. It is now bound to 'revert-buffer', which +will update the data. + +'package-menu-refresh' is an obsolete alias for 'revert-buffer'. + +** Info + +*** Clicking on the left/right arrow icon in the Info tool-bar while +holding down the Ctrl key pops up a menu of previously visited Info nodes +where you can select a node to go back (like in browsers). + +*** Info can now follow 'file://' protocol URLs. +The 'file://' URLs in Info documents can now be followed by passing +them to the 'browse-url' function, like the other protocols: 'ftp', +'http', and 'https'. This allows having references to local HTML +files, for example. + +** Display of man pages now limits the width for formatting pages. +The new user option 'Man-width-max' (80 by default) limits the number +of columns passed to the 'man' program for formatting man pages. This +is to enhance readability when man pages are displayed in very wide +windows (which are customary with today's large displays). + +** Xref + +*** New command 'xref-find-definitions-at-mouse'. +This command finds definitions of the identifier at the place of a +mouse click event, and is intended to be bound to a mouse event. + +*** Changing 'xref-marker-ring-length' works after xref.el is loaded. +Previously, setting 'xref-marker-ring-length' would only take effect +if set before xref.el was loaded. + +*** 'xref-find-definitions' now sets the mark at the buffer position +where it was invoked. + +*** New xref faces 'xref-file-header', 'xref-line-number', 'xref-match'. + +*** New user option 'xref-show-definitions-function'. +It encapsulates the logic pertinent to showing the result of +'xref-find-definitions'. The user can change it to customize its +behavior and the display of results. + +*** Search results show the buffer even for one hit. +The search-type Xref commands (e.g. 'xref-find-references' or +'project-find-regexp') now show the results buffer even when there is +only one hit. This can be altered by changing 'xref-show-xrefs-function'. + +*** Xref buffers support refreshing the search results. +A new command 'xref-revert-buffer' is bound to 'g'. + +*** Imenu support has been added to 'xref--xref-buffer-mode'. + +*** New generic method 'xref-backend-identifier-completion-ignore-case'. +Using it, the etags backend now honors 'tags-case-fold-search' during +identifier completion. + +** Checkdoc + +*** Checkdoc can now optionally spell-check doc strings. +Invoking 'checkdoc-buffer' with a non-nil TAKE-NOTES argument +(interactively, with a prefix arg) will now spell-check the doc +strings and report all the spelling mistakes. + +** Icomplete + +*** New minor mode Fido mode. +This mode is based on Icomplete, and its name stands for "Fake Ido". +The point of this mode is to be an 'ido-mode' workalike, providing +most of the functionality present in 'ido-mode' that is not in +Icomplete, which is much more compatible with all of Emacs's +completion facilities. + +** Ecomplete + +*** The Ecomplete sorting has changed to a decay-based algorithm. +This can be controlled by the new 'ecomplete-sort-predicate' user option. + +*** The 'ecomplete-database-file' file is now placed in +"~/.emacs.d/ecompleterc" by default. Of course it will still find it +if you have it in "~/.ecompleterc". + +** Gnus + +*** 'mm-uu-diff-groups-regexp' now defaults to matching all groups, +which means that "git am" diffs are recognized everywhere. + +*** Two new Gnus summary mode navigation commands have been added, +bound to the '[' and ']' keys: 'gnus-summary-prev-unseen-article' and +'gnus-summary-next-unseen-article'. These take you (respectively) to +the previous unseen or next unseen article. (These are the ones that +are marked with "." in the summary mode lines.) + +*** The Gnus user variable 'nnimap-expunge' supports three new values: +'never' for never expunging messages, 'immediately' for immediately +expunging deleted messages, and 'on-exit' to expunge deleted articles +when exiting the group's summary buffer. Setting 'nnimap-expunge' to +nil or t is still supported but not recommended, since it may +result in Gnus expunging all messages that have been flagged as +deleted by any IMAP client (rather than just those that have been +deleted by Gnus). + +*** New user option 'gnus-use-atomic-windows' makes Gnus window layouts atomic. +See the "(elisp) Atomic Windows" node of the Elisp manual for details. + +*** There's a new value for 'gnus-article-date-headers', +'combined-local-lapsed', which will show both the time (in the local +timezone) and the lapsed time. + +*** Gnus now maps imaps to 993 only on old MS-Windows versions. +The nnimap backend used to do this unconditionally to work around +problems on old versions of MS-Windows. This is now done only for +Windows XP and older. + +*** The nnimap backend now has support for IMAP namespaces. +This feature can be enabled by setting the new 'nnimap-use-namespaces' +server variable to non-nil. + +*** A prefix argument to 'gnus-summary-limit-to-score' will limit in reverse. +Limit to articles with score "at or below" the SCORE argument rather +than "at or above". + +*** The function 'gnus-score-find-favorite-words' has been renamed +from 'gnus-score-find-favourite-words'. + +*** Gmane has been removed as an nnir backend, since Gmane no longer +has a search engine. + +*** Splitting mail on common mailing list headers has been added. +See the concept index in the Gnus manual for the 'match-list' entry. + +*** nil is no longer an allowed value for 'mm-text-html-renderer'. + +*** The default value of 'mm-inline-large-images' has changed from nil +to 'resize', which means that large images will be resized instead of +displayed with an external program by default. + +*** A new Gnus summary mode command, 'S A' ('gnus-summary-attach-article') +can be used to attach the current article(s) to a pre-existing Message +buffer, or create a new Message buffer with the article(s) attached. + +*** A new Gnus summary mode command, 'w' ('gnus-summary-browse-url') +scans the article buffer for URLs, and offers them to the user to open +with 'browse-url'. + +*** New user option 'nnir-notmuch-filter-group-names-function'. +This option controls whether and how to use Gnus search groups as +'path:' search terms to 'notmuch'. + +*** The buttons in the Gnus article buffer were formerly widgets +(i.e., buttons from widget.el). This has now changed, and they are +now buttons (from button.el), and commands like 'TAB' now search for +buttons instead of widgets. There should be no user-visible changes, +but out-of-tree code that relied on widgets being present might now +fail. + +** erc + +*** New hook 'erc-insert-done-hook'. +This hook is called after strings have been inserted into the buffer, +and is free to alter point and window configurations, as it's not +called from inside a 'save-excursion', as opposed to 'erc-insert-post-hook'. + +*** 'erc-button-google-url' has been renamed to 'erc-button-search-url' +and its value has been changed to Duck Duck Go. + +*** 'erc-send-pre-hook' and 'erc-send-this' have been obsoleted. +The user option to use instead to alter text to be sent is now +'erc-pre-send-functions'. + +*** Improve matching/highlighting of nicknames. +Open and close parenthesis and apostrophe are not considered valid +nick characters anymore, matching the given grammar in RFC 2812 +section 2.3.1. This enables correct matching and highlighting of +nicks when they are surrounded by parentheses, like "(nick)", and when +adjacent to an apostrophe, like "nick's". + +*** Set 'erc-button-url-regexp' to 'browse-url-button-regexp' +which better handles surrounding pair of parentheses. + +*** New function 'erc-switch-to-buffer-other-window' +which is like 'erc-switch-to-buffer', but opens the buffer in another +window. + +*** New function 'erc-track-switch-buffer-other-window' +which is like 'erc-track-switch-buffer', but opens the buffer in +another window. + +** EUDC + +*** XEmacs support has been removed. + +** eww/shr + +*** The new user option 'shr-cookie-policy' can be used to control +when to use cookies when fetching embedded images. The default is to +use them when the images are from the same domain as the main HTML +document. + +*** The 'eww' command can now create a new EWW buffer. +Invoking the command with a prefix argument will cause it to create a +new EWW buffer for the URL instead of reusing the default one. + +*** Clicking with the Ctrl key or 'C-u RET' on a link opens a new tab +when tab-bar-mode is enabled. + +*** The 'd' ('eww-download') command now falls back to current page's URL. +If this command is invoked with no URL at point, it now downloads the +current page instead of signaling an error. + +*** When opening external links in eww/shr (typically with the +'C-u RET' keystroke on a link), the link will be flashed with the new +'shr-selected-link' face to give the user feedback that the command +has been executed. + +*** New user option 'shr-discard-aria-hidden'. +If set, shr will not render tags with attribute 'aria-hidden="true"'. +This attribute is meant to tell screen readers to ignore a tag. + +*** 'shr-external-browser' has been made into an obsolete alias +of 'browse-url-secondary-browser-function'. + +*** 'shr-tag-ol' now respects the ordered list 'start' attribute. + +*** The following tags are now handled: '<code>', '<abbr>', and '<acronym>'. + +** Htmlfontify + +*** The functions 'hfy-color', 'hfy-color-vals' and +'hfy-fallback-color-values' and the variables 'hfy-fallback-color-map' +and 'hfy-rgb-txt-color-map' have been renamed from names that used +'colour' instead of 'color'. + +** Enriched mode supports the 'charset' text property. +You can add or modify the 'charset' text properties of text using the +'Edit->Text Properties->Special Properties' menu, or by invoking the +'facemenu-set-charset' command. Documents in Enriched mode will be +saved with the charset properties, and those properties will be +restored when the file is visited. + +** Smtpmail + +*** Authentication mechanisms can be added via external packages, by +defining new 'cl-defmethod' of 'smtpmail-try-auth-method'. + +*** To always force smtpmail to send credentials over on the first +attempt when communicating with the SMTP server(s), the +'smtpmail-servers-requiring-authorization' user option can be used. + +*** smtpmail will now try resending mail when getting a transient "4xx" +error message from the SMTP server. The new 'smtpmail-retries' +user option says how many times to retry. + +** Footnote mode + +*** Support Hebrew-style footnotes. + +*** Footnote text lines are now aligned. +Can be controlled via the new user option 'footnote-align-to-fn-text'. + +** CSS mode + +*** A new command 'css-cycle-color-format' for cycling between color +formats (e.g. "black" => "#000000" => "rgb(0, 0, 0)") has been added, +bound to 'C-c C-f'. + +*** CSS mode, SCSS mode, and Less CSS mode now have support for Imenu. + +** SGML mode + +*** 'sgml-quote' now handles double quotes and apostrophes +when escaping text and in addition all numeric entities when +unescaping text. + +** Python mode + +*** Python mode supports three different font lock decoration levels. +The maximum level is used by default; customize +'font-lock-maximum-decoration' to tone down the decoration. + +*** New user option 'python-pdbtrack-kill-buffers'. +If non-nil, the default, buffers opened during pdbtracking session are +killed when pdbtracking session is finished. + +*** New function 'python-shell-send-statement. +It sends the statement delimited by 'python-nav-beginning-of-statement' +and 'python-nav-end-of-statement' to the inferior Python process. + +** Help + +*** Descriptions of variables and functions give an estimated first release +where the variable or function appeared in Emacs. + +*** Output format of 'C-h l' ('view-lossage') has changed. +For convenience, 'view-lossage' now displays the last keystrokes +and commands in the same format as the edit buffer of +'edit-last-kbd-macro'. This makes it possible to copy the lines from +the buffer generated by 'view-lossage' to the "*Edit Macro*" buffer +created by 'edit-last-kbd-macro', and to save the macro by 'C-c C-c'. + +*** The list of help commands produced by 'C-h C-h' ('help-for-help') +can now be searched via 'C-s'. + +** Ibuffer + +*** New filter 'ibuffer-filter-by-process'; bound to '/ E'. + +*** All mode filters can now accept a list of symbols. +This means you can now easily filter several major modes, as well +as a single mode. + +** Search and Replace + +*** Isearch supports a prefix argument for 'C-s' ('isearch-repeat-forward') +and 'C-r' ('isearch-repeat-backward'). With a prefix argument, these +commands repeat the search for the specified occurrence of the search string. +A negative argument repeats the search in the opposite direction. +This makes possible also to use a prefix argument for 'M-s .' +('isearch-forward-symbol-at-point') to find the next Nth symbol. +Also a prefix argument is supported for 'isearch-yank-until-char', +'isearch-yank-word-or-char', 'isearch-yank-symbol-or-char'. + +*** To go to the first/last occurrence of the current search string +is possible now with new commands 'isearch-beginning-of-buffer' and +'isearch-end-of-buffer' bound to 'M-s M-<' and 'M-s M->' in Isearch. +With a numeric argument, they go to the Nth absolute occurrence +counting from the beginning/end of the buffer. This complements +'C-s'/'C-r' that searches for the next Nth relative occurrence +with a numeric argument. + +*** 'isearch-lazy-count' shows the current match number and total number +of matches in the Isearch prompt. User options +'lazy-count-prefix-format' and 'lazy-count-suffix-format' define the +format of the current and the total number of matches in the prompt's +prefix and suffix, respectively. + +*** 'lazy-highlight-buffer' highlights matches in the full buffer. +It is useful in combination with 'lazy-highlight-cleanup' customized to nil +to leave matches highlighted in the whole buffer after exiting isearch. +Also when 'lazy-highlight-buffer' prepares highlighting in the buffer, +navigation through the matches without flickering is more smooth. +'lazy-highlight-buffer-max-at-a-time' controls the number of matches to +highlight in one iteration while processing the full buffer. + +*** New isearch bindings. +'C-M-z' invokes new function 'isearch-yank-until-char', which yanks +everything from point up to but not including the specified +character into the search string. This is especially useful for +keyboard macros. + +'C-M-w' in isearch changed from 'isearch-del-char' to the new function +'isearch-yank-symbol-or-char'. 'isearch-del-char' is now bound to +'C-M-d'. + +'M-s h l' invokes 'highlight-lines-matching-regexp' using the search +string to highlight lines matching the search string. This is similar +to the existing binding 'M-s h r' ('highlight-regexp') that highlights +JUST the search string. + +*** New user option 'isearch-yank-on-move' provides options t and 'shift' +to extend the search string by yanking text that ends at the new +position after moving point in the current buffer. 'shift' extends +the search string by motion commands while holding down the shift key. + +*** 'isearch-allow-scroll' provides a new option 'unlimited' to allow +scrolling any distance off screen. + +*** Isearch now remembers the regexp-based search mode for words/symbols +and case-sensitivity together with search strings in the search ring. + +*** Isearch now has its own tool-bar and menu-bar menu. + +*** 'flush-lines' prints and returns the number of deleted matching lines. + +*** 'char-fold-to-regexp' now matches more variants of a base character. +The table used to check for equivalence of characters is now built +using the complete chain of unicode decompositions of a character, +rather than stopping after one level, such that searching for +e.g. "GREEK SMALL LETTER IOTA" will now also find "GREEK SMALL LETTER +IOTA WITH OXIA". + +*** New char-folding options: 'char-fold-include' lets you add ad hoc +foldings, 'char-fold-exclude' to remove foldings from default decomposition, +and 'char-fold-symmetric' to search for any of an equivalence class of +characters. For example, with a nil value of 'char-fold-symmetric' +you can search for "e" to find "é", but not vice versa. With a non-nil +value you can search for either, for example, you can search for "é" +to find "e". + +** Debugger + +*** The Lisp Debugger is now based on 'backtrace-mode'. +Backtrace mode adds fontification and commands for changing the +appearance of backtrace frames. See the node "(elisp) Backtraces" in +the Elisp manual for documentation of the new mode and its commands. + +** Edebug + +*** 'edebug-eval-last-sexp' and 'edebug-eval-print-last-sexp' interactively +now take a zero prefix analogously to the non-Edebug counterparts. + +*** New faces 'edebug-enabled-breakpoint' and 'edebug-disabled-breakpoint'. +When setting breakpoints in Edebug, an overlay with these faces are +placed over the point in question, depending on whether they are +enabled or not. + +*** New command 'edebug-toggle-disable-breakpoint'. +This command allows you to disable a breakpoint temporarily. This is +mainly useful with breakpoints that are conditional and would take +some time to recreate. + +*** New command 'edebug-unset-breakpoints'. +To clear all breakpoints in the current form, the 'U' command in +'edebug-mode', or 'M-x edebug-unset-breakpoints' can be used. + +*** Re-instrumenting a function with Edebug will now try to preserve +previously-set breakpoints. However, if the code has changed +substantially, this may not be possible. + +*** New command 'edebug-remove-instrumentation'. +This command removes Edebug instrumentation from all functions that +have been instrumented. + +*** The runtime behavior of Edebug's instrumentation can be changed +using the new variables 'edebug-behavior-alist', +'edebug-after-instrumentation-function' and +'edebug-new-definition-function'. Edebug's behavior can be changed +globally or for individual definitions. + +*** Edebug's backtrace buffer now uses 'backtrace-mode'. +Backtrace mode adds fontification, links and commands for changing the +appearance of backtrace frames. See the node "(elisp) Backtraces" in +the Elisp manual for documentation of the new mode and its commands. + +The binding of 'd' in Edebug's keymap is now 'edebug-pop-to-backtrace' +which replaces 'edebug-backtrace'. Consequently Edebug's backtrace +windows now behave like those of the Lisp Debugger and of ERT, in that +when they appear they will be the selected window. + +The new 'backtrace-goto-source' command, bound to 's', works in +Edebug's backtraces on backtrace frames whose source code has +been instrumented by Edebug. + +** Enhanced xterm support + +*** New user option 'xterm-set-window-title' controls whether Emacs sets +the XTerm window title. This feature is experimental and is disabled +by default. + +** Grep + +*** 'rgrep', 'lgrep' and 'zrgrep' now hide part of the command line +that contains a list of ignored directories and files. +Clicking on the button with ellipsis unhides it. +The abbreviation can be disabled by the new user option +'grep-find-abbreviate'. The new command +'grep-find-toggle-abbreviation' toggles it interactively. + +*** 'grep-find-use-xargs' is now customizable with sorting options. + +** ERT + +*** New variable 'ert-quiet' allows making ERT output in batch mode +less verbose by removing non-essential information. + +*** ERT's backtrace buffer now uses 'backtrace-mode'. +Backtrace mode adds fontification and commands for changing the +appearance of backtrace frames. See the node "(elisp) Backtraces" in +the Elisp manual for documentation of the new mode and its commands. + +** Gamegrid + +*** Gamegrid now determines its default glyph size based on display +dimensions, instead of always using 16 pixels. As a result, Tetris, +Snake and Pong are better playable on HiDPI displays. + +*** 'gamegrid-add-score' can now sort scores from lower to higher. +This is useful for games where lower scores are better, like time-based games. + +** Filecache + +*** Completing file names in the minibuffer via 'C-TAB' now uses the +styles as configured by the user option 'completion-styles'. + +** New macros 'thunk-let' and 'thunk-let*'. +These macros are analogue to 'let' and 'let*', but create bindings that +are evaluated lazily. + +** next-error + +*** New user option 'next-error-find-buffer-function'. +The value should be a function that determines how to find the +next buffer to be used by 'next-error' and 'previous-error'. The +default is to use the last buffer that navigated to the current +error. + +*** New command 'next-error-select-buffer'. +It can be used to set any buffer as the next one to be used by +'next-error' and 'previous-error'. + +** nxml-mode + +*** The default value of 'nxml-sexp-element-flag' is now t. +This means that pressing 'C-M-SPACE' now selects the entire tree by +default, and not just the opening element. + +** Eshell + +*** TAB completion uses the standard 'completion-at-point' rather than +'pcomplete'. Its UI is slightly different but can be customized to +behave similarly, e.g. Pcomplete's default cycling can be obtained +with '(setq completion-cycle-threshold 5)'. + +*** Expansion of history event designators is disabled by default. +To restore the old behavior, use + + (add-hook 'eshell-expand-input-functions + #'eshell-expand-history-references) + +*** The function 'eshell-uniquify-list' has been renamed from +'eshell-uniqify-list'. + +*** The function 'eshell/kill' is now able to handle signal switches. +Previously 'eshell/kill' would fail if provided a kill signal to send +to the process. It now accepts signals specified either by name or by +its number. + +*** Emacs now follows symlinks in history-related files. +The files specified by 'eshell-history-file-name' and +'eshell-last-dir-ring-file-name' can include symlinks; these are now +followed when Emacs writes the relevant history variables to the disk. + +** Shell + +*** Program name completion inside remote shells works now as expected. + +*** The user option 'shell-file-name' can be set now as connection-local +variable for remote shells. It still defaults to "/bin/sh". + +** Single shell commands + +*** New values of 'shell-command-dont-erase-buffer'. +This user option can now have the value 'erase' to force to erase the +output buffer before execution of the command, even if the output goes +to the current buffer. Additional values 'beg-last-out', +'end-last-out', and 'save-point' control where to put point in the +output buffer after inserting the 'shell-command' output. + +*** The new functions 'shell-command-save-pos-or-erase' and +'shell-command-set-point-after-cmd' control how point is handled +between two consecutive shell commands in the same output buffer. + +*** 'async-shell-command-width' defines the number of display columns +available for output of asynchronous shell commands. + +*** Prompt for shell commands can now show the current directory. +Customize the new user option 'shell-command-prompt-show-cwd' to enable it. + +** Pcomplete + +*** The 'pcomplete' command is now obsolete. +The Pcomplete functionality can be obtained via 'completion-at-point' +instead, by adding 'pcomplete-completions-at-point' to +'completion-at-point-functions'. + +*** The function 'pcomplete-uniquify-list' has been renamed from +'pcomplete-uniqify-list'. + +*** 'pcomplete/make' now completes on targets in included files, recursively. +To recover the previous behavior, set new user option +'pcmpl-gnu-makefile-includes' to nil. + +** Auth-source + +*** The Secret Service backend supports the ':create' key now. + +*** ".authinfo" and ".netrc" files now use a new mode: 'authinfo-mode'. +This is just like 'fundamental-mode', except that it hides passwords +under a "****" display property. When the cursor moves to this text, +the real password is revealed (via 'reveal-mode'). The new +'authinfo-hidden' user option can be used to control what to hide. + +** Tramp + +*** New connection method "nextcloud", which allows accessing OwnCloud +or NextCloud hosted files and directories. + +*** New connection method "rclone", which allows accessing system +storages via the 'rclone' program. This feature is experimental. + +*** New connection method "sudoedit", which allows editing local files +with different user credentials. Contrary to the "sudo" method, no +session is run permanently in the background. This is for security +reasons. + +*** Connection methods "obex" and "synce" have been removed, because they +are obsoleted in GVFS. + +*** Validated passwords are saved by auth-source backends which support this. + +*** During user and host name completion in the minibuffer, results +from auth-source search are taken into account. This can be disabled +by setting the user option 'tramp-completion-use-auth-sources' to nil. + +*** The user option 'tramp-ignored-file-name-regexp' allows disabling +Tramp for some look-alike remote file names. + +*** For some connection methods, like "su" or "sudo", the host name in +multi-hop file names must match the previous hop. Default host names +are adjusted to the host name from the previous hop. + +*** A timeout has been added for the connection methods "sudo" and "doas". +The underlying session is disabled when the timeout expires. This is +for security reasons. + +*** For some connection methods, like "sshx" or "plink", it is +possible to configure the remote login shell. This avoids problems +with remote hosts, where "/bin/sh" is a link to a shell which +cooperates badly with Tramp. + +*** New commands 'tramp-rename-files' and 'tramp-rename-these-files'. +They allow saving remote files somewhere else when the corresponding +host is not reachable anymore. + +** Rcirc + +*** New user option 'rcirc-url-max-length'. +Setting this option to an integer causes URLs displayed in Rcirc +buffers to be truncated to that many characters. + +*** The default '/quit' and '/part' reasons are now configurable. +Two new user options are provided for this: +'rcirc-default-part-reason' and 'rcirc-default-quit-reason'. + +** Register + +*** The return value of method 'register-val-describe' includes the +names of buffers shown by the windows of a window configuration. + +** Message + +*** Completion of email addresses can use the standard completion UI. +This is controlled by 'message-expand-name-standard-ui'. +With the standard UI the different sources (ecomplete, bbdb, and eudc) +are matched together and try to obey 'completion-styles'. +It should work for other completion front ends like Company. + +*** 'message-mode' now supports highlighting citations of different depths. +This can be customized via the new user option +'message-cite-level-function' and the new 'message-cited-text-*' faces. + +*** Messages can now be systematically encrypted +when the PGP keyring contains a public key for every recipient. To +achieve this, add 'message-sign-encrypt-if-all-keys-available' to +'message-send-hook'. + +*** When replying a message that have addresses on the form +'"foo@bar.com" <foo@bar.com>', Message will elide the repeated "name" +from the address field in the response. + +*** The default of 'message-forward-as-mime' has changed from t to nil +as it has been reported that many recipients can't read forwards that +are formatted as MIME digests. + +*** 'message-forward-included-headers' has changed its default to +exclude most headers when forwarding. + +*** 'mml-secure-openpgp-sign-with-sender' sets also "gpg --sender". +When 'mml-secure-openpgp-sign-with-sender' is non-nil, message sender's +email address (in addition to its old behavior) will also be used to +set gpg's "--sender email@domain" option. + +The option is useful for two reasons when verifying the signature: + + 1. GnuPG's TOFU statistics are updated for the specific user id + (email) only. See gpg(1) man page about "--sender". + + 2. GnuPG's "--auto-key-retrieve" functionality can use WKD (web key + directory) method for finding the signer's key. You need GnuPG + 2.2.17 to fully benefit from this feature. See gpg(1) man page for + "--auto-key-retrieve". + +*** The 'mail-from-style' variable is now obsolete. +According to RFC 5322, only the 'angles' value is valid. + +** EasyPG + +*** 'epa-pinentry-mode' is renamed to 'epg-pinentry-mode'. +It now applies to epg functions as well as epa functions. + +*** The alias functions 'epa--encode-coding-string', +'epa--decode-coding-string', and 'epa--select-safe-coding-system' have +been removed. Use 'encode-coding-string', 'decode-coding-string', and +'select-safe-coding-system' instead. + +*** 'epg-context' structure supports now 'sender' slot. +The value of the new 'sender' slot (if a string) is used to set gpg's +"--sender" option. This feature is used by +'mml-secure-openpgp-sign-with-sender'. See gpg(1) manual page about +"--sender" for more information. + +** Rmail + +*** New user option 'rmail-output-reset-deleted-flag'. +If this option is non-nil, messages appended to an output file by the +'rmail-output' command have their Deleted flag reset. + +*** The command 'rmail-summary-by-senders' with an empty argument +selects the messages to summarize with a regexp that matches the +sender of the current message. + +** Threads + +*** New variable 'main-thread' holds Emacs's main thread. +This is handy in Lisp programs that run on a non-main thread and want +to signal the main thread, e.g., when they encounter an error. + +*** 'thread-join' now returns the result of the finished thread. + +*** 'thread-signal' does not propagate errors to the main thread. +Instead, error messages are just printed in the main thread. + +*** 'thread-alive-p' is now obsolete, use 'thread-live-p' instead. + +*** New command 'list-threads' shows Lisp threads. +See the current list of live threads in a tabulated-list buffer which +automatically updates. In the buffer, you can use 's q' or 's e' to +signal a thread with quit or error respectively, or get a snapshot +backtrace with 'b'. + +** thingatpt.el + +*** 'thing-at-point' supports a new "thing" called 'uuid'. +A symbol 'uuid' can be passed to 'thing-at-point' and it returns the +UUID at point. + +*** 'number-at-point' will now recognize hex numbers like 0xAb09 and #xAb09 +and return them as numbers. + +*** 'word-at-point' and 'sentence-at-point' accept NO-PROPERTIES. +Just like 'thing-at-point' itself. + +** Interactive automatic highlighting + +*** 'highlight-regexp' can now highlight subexpressions. +The new command accepts a prefix numeric argument to choose the +subexpression. + +** Mouse display of minor mode menu + +*** 'minor-mode-menu-from-indicator' now displays full minor mode name. +When there is no menu for a mode, display the mode name after the +indicator instead of just the indicator (which is sometimes cryptic). + +** rx + +*** rx now handles raw bytes in character alternatives correctly, +when given in a string. Previously, '(any "\x80-\xff")' would match +characters U+0080...U+00FF. Now the expression matches raw bytes in +the 128...255 range, as expected. + +*** The rx 'or' and 'seq' forms no longer require any arguments. +'(or)' produces a regexp that never matches anything, while '(seq)' +matches the empty string, each being an identity for the operation. +This also works for their aliases: '|' for 'or'; ':', 'and' and +'sequence' for 'seq'. +The symbol 'unmatchable' can be used as an alternative to '(or)'. + +*** 'regexp' and new 'literal' accept arbitrary lisp as arguments. +In this case, 'rx' will generate code which produces a regexp string +at run time, instead of a constant string. + +*** New rx extension mechanism: 'rx-define', 'rx-let', 'rx-let-eval'. +These macros add new forms to the rx notation. + +*** 'anychar' is now an alias for 'anything'. +Both match any single character; 'anychar' is more descriptive. + +*** New 'intersection' form for character sets. +With 'or' and 'not', it can be used to compose character-matching +expressions from simpler parts. + +*** 'not' now accepts more argument types. +The argument can now also be a character, a single-character string, +an 'intersection' form, or an 'or' form whose arguments each match a +single character. + +*** Nested 'or' forms of strings guarantee a longest match. +For example, '(or (or "IN" "OUT") (or "INPUT" "OUTPUT"))' now matches +the whole string "INPUT" if present, not just "IN". Previously, this +was only guaranteed inside a single 'or' form of string literals. + +** Frames + +*** New command 'make-frame-on-monitor' makes a frame on the specified monitor. + +*** New value of 'minibuffer' frame parameter 'child-frame'. +This allows creating and immediately parenting a minibuffer-only child +frame when making a frame. + +*** New predicates 'display-blink-cursor-p' and 'display-symbol-keys-p'. +These predicates are to be preferred over 'display-graphic-p' when +testing for blinking cursor capability and the capability to have +symbols (e.g., '[return]', '[tab]', '[backspace]') as keys respectively. + +** Tabulated List mode + +*** New user options for tabulated list sort indicators. +You can now customize which sorting indicator character to display +near the current column in Tabulated Lists (see user options +'tabulated-list-gui-sort-indicator-asc', +'tabulated-list-gui-sort-indicator-desc', +'tabulated-list-tty-sort-indicator-asc', and +'tabulated-list-tty-sort-indicator-desc'). + +*** Two new commands and keystrokes have been added to the tabulated +list mode: 'w' (which widens the current column) and 'c' which makes +the current column contract. + +*** New function 'tabulated-list-clear-all-tags'. +This function clears all tags from the padding area in the current +buffer. Tags are typically added by calling 'tabulated-list-put-tag'. + +** Text mode + +*** 'text-mode-variant' is now obsolete, use 'derived-mode-p' instead. + +** CUA mode + +*** New user option 'cua-rectangle-terminal-modifier-key'. +This user option allows for the customization of the modifier key used +in a terminal frame. + +** JS mode + +*** JSX syntax is now automatically detected and enabled. +If a file imports Facebook's 'React' library, or if the file uses the +extension ".jsx", then various features supporting XML-like syntax +will be supported in 'js-mode' and derivative modes. ('js-jsx-mode' +no longer needs to be enabled.) + +*** New user option 'js-jsx-detect-syntax' disables automatic detection. +This is turned on by default. + +*** New user option 'js-jsx-syntax' enables JSX syntax unconditionally. +This is off by default. + +*** New variable 'js-jsx-regexps' controls JSX detection. + +*** JSX syntax is now highlighted like SGML. + +*** JSX code is properly indented in many more scenarios. +Previously, JSX indentation usually only worked when an element was +wrapped in parenthesis (e.g. in a 'return' statement or a function +call). It would also fail in many intricate cases. Now, indentation +should work anywhere without parenthesis; many more intricacies are +supported; and, indentation conventions align more closely with those +of the React developer community (see 'js-jsx-align->-with-<'), +otherwise still adhering to SGML conventions. + +*** New user option 'js-jsx-align->-with-<' controls '>' indents. +Commonly in JSX code, a '>' on its own line is indented at the same +level as its opening '<'. This is the new default for JSX. This +behavior is slightly different than that used by SGML in Emacs, where +'>' is indented at the same level as attributes, which was also the +old default for JSX. + +This is turned on by default. To get back the old default indentation +behavior of aligning '>' with attributes, set 'js-jsx-align->-with-<' +to nil. + +*** Indentation uses 'js-indent-level' instead of 'sgml-basic-offset'. +Since JSX is a syntax extension of JavaScript, it makes the most sense +for JSX expressions to be indented the same number of spaces as other +JS expressions. This is a breaking change, but it probably aligns +with how you'd expect this indentation to behave. If you want JSX to +be indented like JS, you won't need to change your config. + +The old behavior can be emulated by controlling JSX indentation +independently of JS, by setting 'js-jsx-indent-level'. + +*** New user option 'js-jsx-indent-level' for different JSX indentation. +If you wish to indent JSX by a different number of spaces than JS, set +this user option to the desired number. + +*** New user option 'js-jsx-attribute-offset' for JSX attribute indents. + +*** New variable 'js-syntactic-mode-name' controls mode name display. +Previously, the mode name was simply 'JavaScript'. Now, when a syntax +extension like JSX is enabled, the mode name is 'JavaScript[JSX]'. +Set this variable to nil to disable the new behavior. + +*** New function 'js-use-syntactic-mode-name' for deriving modes. +Packages deriving from 'js-mode' with 'define-derived-mode' should +call this function to add enabled syntax extensions to their mode +name, too. + +** Autorevert + +*** New user option 'auto-revert-avoid-polling' for saving power. +When set to a non-nil value, buffers in Auto Revert mode are no longer +polled for changes periodically. This reduces the power consumption +of an idle Emacs, but may fail on some network file systems; set +'auto-revert-notify-exclude-dir-regexp' to match files where +notification is not supported. The default value is nil. + +*** New variable 'buffer-auto-revert-by-notification'. +A major mode can declare that notification on the buffer's default +directory is sufficient to know when updates are required, by setting +the new variable 'buffer-auto-revert-by-notification' to a non-nil +value. Auto Revert mode can use this information to avoid polling the +buffer periodically when 'auto-revert-avoid-polling' is non-nil. + +*** 'global-auto-revert-ignore-buffer' can now also be a predicate +function that can be used for more fine-grained control of which +buffers to auto-revert. + +** auth-source-pass + +*** New user option 'auth-source-pass-filename'. +Allows setting the path to the password-store, defaults to +"~/.password-store". + +*** New user option 'auth-source-pass-port-separator'. +Specifies separator between host and port, defaults to colon ":". + +*** Minimize the number of decryptions during password lookup. +This makes the package usable with physical tokens requiring touching +a sensor for every decryption. + +*** 'auth-source-pass-get' is now autoloaded. + +** Bookmarks + +*** 'bookmark-file' and 'bookmark-old-default-file' are now obsolete +aliases of 'bookmark-default-file'. + +*** New user option 'bookmark-watch-bookmark-file'. +When non-nil, watch whether the bookmark file has changed on disk. + +*** The old bookmark file format is no longer supported. +This bookmark file format has not been used in Emacs since at least +version 19.34, released in 1996, and will no longer be automatically +converted to the new bookmark file format. + +The following functions are now declared obsolete: +'bookmark-grok-file-format-version', +'bookmark-maybe-upgrade-file-format', +'bookmark-upgrade-file-format-from-0', and +'bookmark-upgrade-version-0-alist'. + +** The mantemp.el library is now marked obsolete. +This library generates manual C++ template instantiations. It should +no longer be useful on modern compilers, which do this automatically. + +** Ispell + +*** New hook 'ispell-change-dictionary-hook'. +This runs after changing the dictionary and could be used to +automatically spellcheck a buffer when changing language without +needing to advice 'ispell-change-dictionary'. + +** scroll-lock + +*** New command 'scroll-lock-next-line-always-scroll'. +This command is bound to 'S-down' and scrolls the buffer up in +particular when the end of the buffer is visible in the window. + +** mwheel.el + +*** 'mwheel-install' is now obsolete. +Use 'mouse-wheel-mode' instead. Note that 'mouse-wheel-mode' is +already enabled by default on most graphical displays. + +** Gravatar + +*** 'gravatar-cache-ttl' is now a number of seconds. +The previously used timestamp format of a list of integers is still +supported, but is deprecated. The default value has not changed. + +*** 'gravatar-size' can now be nil. +This results in the use of Gravatar's default size of 80 pixels. + +*** The default fallback gravatar is now configurable. +This is possible using the new user options 'gravatar-default-image' +and 'gravatar-force-default'. + +** ada-mode + +*** The built-in ada-mode is now deleted. The GNU ELPA package is a +good replacement, even in very large source files. + +** time-stamp + +*** New '%5z' conversion for 'time-stamp-format' gives time zone offset. +Specifying '%5z' in 'time-stamp-format' or 'time-stamp-pattern' +expands to the time zone offset, e.g., '+0100'. The time zone used is +specified by 'time-stamp-time-zone'. + +Because this feature is new in Emacs 27.1, do not use it in the local +variables section of any file that might be edited by an older version +of Emacs. + +*** Some conversions recommended for 'time-stamp-format' have changed. +The new documented/recommended %-conversions are closer to those +used by 'format-time-string' and are compatible at least as far back +as Emacs 22.1 (released in 2007). + +Uppercase abbreviated day name of week: was %3A, now %#a +Full day name of week: was %:a, now %:A +Uppercase abbreviated month name: was %3B, now %#b +Full month name: was %:b, now %:B +Four-digit year: was %:y, now %Y +Lowercase timezone name: was %z, now %#Z +Fully-qualified host name: was %s, now %Q +Unqualified host name: (was none), now %q +Login name: was %u, now %l +User's full name: was %U, now %L + +Merely having '(add-hook 'before-save-hook 'time-stamp)' in your +Emacs init file does not expose you to this change. However, +if you set 'time-stamp-format' or 'time-stamp-pattern' with a +file-local variable, you may need to update the value. + +** mode-local + +*** Declare 'define-overload' and 'define-child-mode' as obsolete. + +*** Rename several internal functions to use a 'mode-local-' prefix. + +** CC Mode + +*** You can now flag "wrong style" comments with 'font-lock-warning-face'. +To do this, use 'c-toggle-comment-style', if needed, to set the desired +default comment style (block or line); then set the user option +'c-mark-wrong-style-of-comment' to non-nil. + +** Mailcap + +*** The new function 'mailcap-file-name-to-mime-type' has been added. +It's a simple convenience function for looking up MIME types based on +file name extensions. + +*** The default way the list of possible external viewers for MIME +types is sorted and chosen has changed. Earlier, the most specific +viewer was chosen, even if there was a general override in "~/.mailcap". +For instance, if "/etc/mailcap" has an entry for "image/gif", that one +will be chosen even if you have an entry for "image/*" in your +"~/.mailcap" file. But with the new method, entries from "~/.mailcap" +overrides all system and Emacs-provided defaults. To get the old +method back, set 'mailcap-prefer-mailcap-viewers' to nil. + +** MH-E + +*** The hook 'mh-show-mode-hook' is now called before the message is inserted. +Functions that want to affect the message text (for example, to change +highlighting) can no longer use 'mh-show-mode-hook', because the +message contents will not yet have been inserted when the hook is +called. Such functions should now be attached to 'mh-show-hook'. + +** URL + +*** The 'file:' handler no longer looks for "index.html" in +directories if you ask it for a "file:///dir" URL. Since this is a +low-level library, such decisions (if they are to be made at all) are +left to higher-level functions. + + +* New Modes and Packages in Emacs 27.1 + +** Tab Bars + +*** Tab Bar mode +The new command 'tab-bar-mode' enables the tab bar at the top of each +frame (including TTY frames), where you can use tabs to switch between +named persistent window configurations. + +The 'C-x t' sequence is the new prefix key for tab-related commands: +'C-x t 2' creates a new tab; 'C-x t 0' deletes the current tab; +'C-x t b' switches to buffer in another tab; 'C-x t f' and 'C-x t C-f' +edit file in another tab; and 'C-TAB' and 'S-C-TAB' switch to the next +or previous tab. You can also switch between tabs and create/delete +tabs with a mouse. + +Tab-related commands are available even when 'tab-bar-mode' is +disabled: by default, they enable 'tab-bar-mode' in that case. + +The X resource "tabBar", class "TabBar" enables the tab bar +when its value is "on", "yes" or "1". + +The user option 'tab-bar-position' specifies where to show the tab bar. + +Tab-related commands can be used even without the tab bar when +'tab-bar-mode' is disabled by a nil value of the user option +'tab-bar-show'. Without the tab bar you can switch between tabs +using completion on tab names, or using 'tab-switcher'. + +Read the new Info node "(emacs) Tab Bars" for full description +of all related features. + +*** Tab Line mode +The new command 'global-tab-line-mode' enables the tab line above each +window, which you can use to switch buffers in the window. Selecting +the previous window-local tab is the same as typing 'C-x <LEFT>' +('previous-buffer'), selecting the next tab is the same as 'C-x <RIGHT>' +('next-buffer'). Both commands support a numeric prefix argument as +a repeat count. Clicking on the plus icon adds a new buffer to the +window-local tab line of buffers. Using the mouse wheel on the tab +line scrolls tabs. + +Read the new Info node "(emacs) Tab Line" for full description +of all related features. + +** fileloop.el lets one setup multifile operations like search&replace. + +** Emacs can now visit files in archives as if they were directories. +This feature uses Tramp and works only on systems which support GVFS, +i.e. GNU/Linux, roughly spoken. See the node "(tramp) Archive file +names" in the Tramp manual for full documentation of these facilities. + +** New library for writing JSONRPC applications (https://jsonrpc.org). +The 'jsonrpc' library enables writing Emacs Lisp applications that +rely on this protocol. Since the protocol is designed to be +transport-agnostic, the library provides an API to implement new +transport strategies as well as a separate API to use them. A +transport implementation for process-based communication, such as is +used by the Language Server Protocol (LSP), is readily available. + +** Backtrace mode improves viewing of Elisp backtraces. +Backtrace mode adds pretty printing, fontification and ellipsis +expansion to backtrace buffers produced by the Lisp debugger, Edebug +and ERT. See the node "(elisp) Backtraces" in the Elisp manual for +documentation of the new mode and its commands. + +** so-long.el helps to mitigate performance problems with long lines. +When 'global-so-long-mode' has been enabled, visiting a file with very +long lines will (subject to configuration) cause the user's preferred +'so-long-action' to be automatically invoked (by default, the buffer's +major mode is replaced by 'so-long-mode'). In extreme cases this can +prevent delays of several minutes, and make Emacs responsive almost +immediately. Type 'M-x so-long-commentary' for full documentation. + + +* Incompatible Lisp Changes in Emacs 27.1 + +** Incomplete destructive splicing support has been removed. +Support for Common Lisp style destructive splicing (",.") was +incomplete and broken for a long time. It has now been removed. + +This means that backquote substitution now works for identifiers +starting with a period ("."). Consider the following example: + + (let ((.foo 42)) `,.foo) + +In the past, this would have incorrectly evaluated to '(\,\. foo)', +but will now instead evaluate to '42'. + +** The REGEXP in 'magic-mode-alist' is now matched case-sensitively. +Likewise for 'magic-fallback-mode-alist'. + +** 'add-hook' does not always add to the front or the end any more. +The replacement of 'append' with 'depth' implies that the function is +not always added to the very front (when append/depth is nil) or the +very end (when append/depth is t) any more because other functions on +the hook may have specified higher/lower depths. This makes it +possible to control the ordering of functions more precisely, as was +already possible in 'add-function' and 'advice-add'. + +** In 'compilation-error-regexp-alist' the old undocumented feature +where 'line' could be a function of 2 arguments has been dropped. + +** 'define-fringe-bitmap' is always defined, even when Emacs is built +without any GUI support. + +** Just loading a theme's file no longer activates the theme's settings. +Loading a theme with 'M-x load-theme' still activates the theme, as it +did before. However, loading the theme's file with 'M-x load-file', +or using 'require' or 'load' in a Lisp program, doesn't actually apply +the theme's settings until you either invoke 'M-x enable-theme' or +type 'M-x load-theme'. (In a Lisp program, calling 'enable-theme' or +invoking 'load-theme' with NO-ENABLE argument omitted or nil has the +same effect of activating a theme whose file has been loaded.) The +special case of the 'user' theme is an exception: it is frequently +used for ad-hoc customizations, so the settings of that theme are by +default applied immediately. + +The variable 'custom--inhibit-theme-enable' controls this behavior; +its default value changed in Emacs 27.1. + +** The REPETITIONS argument of 'benchmark-run' can now also be a variable. + +** Interpretation of relative 'HOME' directory has changed. +If "$HOME" is set to a relative file name, 'expand-file-name' now +interprets it relative to the directory where Emacs was started, not +relative to the 'default-directory' of the current buffer. We recommend +always setting "$HOME" to an absolute file name, so that its meaning is +independent of where Emacs was started. + +** 'file-name-absolute-p' no longer considers "~foo" to be an absolute +file name if there is no user named "foo". + +** The FILENAME argument to 'file-name-base' is now mandatory and no +longer defaults to 'buffer-file-name'. + +** File metadata primitives now signal an error if I/O, access, or +other serious errors prevent them from determining the result. +Formerly, these functions often (though not always) silently returned +nil. For example, if there is an access error, I/O error or low-level +integer overflow when getting the attributes of a file F, +'(file-attributes F)' now signals an error instead of returning nil. +These functions still behave as before if the only problem is that the +file does not exist. The affected primitives are +'directory-files-and-attributes', 'file-acl', 'file-attributes', +'file-modes', 'file-newer-than-file-p', 'file-selinux-context', +'file-system-info', and 'set-visited-file-modtime'. + +** The function 'eldoc-message' now accepts a single argument. +Programs that called it with multiple arguments before should pass +them through 'format' first. Even that is discouraged: for ElDoc +support, you should set 'eldoc-documentation-function' instead of +calling 'eldoc-message' directly. + +** Old-style backquotes now generate an error. +They have been generating warnings for a decade. To interpret +old-style backquotes as new-style, bind the new variable +'force-new-style-backquotes' to t. + +** Defining a Common Lisp structure using 'cl-defstruct' or +'cl-struct-define' whose name clashes with a builtin type (e.g., +'integer' or 'hash-table') now signals an error. + +** When formatting a floating-point number as an octal or hexadecimal +integer, Emacs now signals an error if the number is too large for the +implementation to format. + +** 'logb' now returns infinity when given an infinite or zero argument, +and returns a NaN when given a NaN. Formerly, it returned an extreme +fixnum for such arguments. + +** Some functions and variables obsolete since Emacs 22 have been removed: +'archive-mouse-extract', 'assoc-ignore-case', 'assoc-ignore-representation', +'backward-text-line', 'blink-cursor', 'bookmark-exit-hooks', +'c-opt-op-identitier-prefix', 'comint-use-prompt-regexp-instead-of-fields', +'compilation-finish-function', 'count-text-lines', 'cperl-vc-header-alist', +'custom-face-save-command', 'cvs-display-full-path', 'cvs-fileinfo->full-path', +'delete-frame-hook', 'derived-mode-class', 'describe-char-after', +'describe-project', 'desktop-basefilename', 'desktop-buffer-handlers', +'desktop-buffer-misc-functions', 'desktop-buffer-modes-to-save', +'desktop-enable', 'desktop-load-default', 'dired-omit-files-p', +'disabled-command-hook', 'dungeon-mode-map', 'electric-nroff-mode', +'electric-nroff-newline', 'electric-perl-terminator', 'executing-macro', +'focus-frame', 'forward-text-line', 'generic-define-mswindows-modes', +'generic-define-unix-modes', 'generic-font-lock-defaults', +'goto-address-at-mouse', 'highlight-changes-colours', +'ibuffer-elide-long-columns', 'ibuffer-hooks', 'ibuffer-mode-hooks', +'icalendar-convert-diary-to-ical', 'icalendar-extract-ical-from-buffer', +'imenu-always-use-completion-buffer-p', 'ipconfig-program', +'ipconfig-program-options', 'isearch-lazy-highlight-cleanup', +'isearch-lazy-highlight-initial-delay', 'isearch-lazy-highlight-interval', +'isearch-lazy-highlight-max-at-a-time', 'iswitchb-use-fonts', +'latin1-char-displayable-p', 'mouse-wheel-click-button', +'mouse-wheel-down-button', 'mouse-wheel-up-button', 'new-frame', +'pascal-outline', 'process-kill-without-query', +'recentf-menu-append-commands-p', 'rmail-pop-password', +'rmail-pop-password-required', 'savehist-load', 'set-default-font', +'spam-list-of-processors', 'speedbar-add-ignored-path-regexp', +'speedbar-buffers-line-path', 'speedbar-ignored-path-expressions', +'speedbar-ignored-path-regexp', 'speedbar-line-path', 'speedbar-path-line', +'timer-set-time-with-usecs', 'tooltip-gud-display', 'tooltip-gud-modes', +'tooltip-gud-toggle-dereference', 'unfocus-frame', 'unload-hook-features-list', +'update-autoloads-from-directories', 'vc-comment-ring', 'vc-comment-ring-index', +'vc-comment-search-forward', 'vc-comment-search-reverse', +'vc-comment-to-change-log', 'vc-diff-switches-list', 'vc-next-comment', +'vc-previous-comment', 'view-todo', 'x-lost-selection-hooks', +'x-sent-selection-hooks'. + +** Further functions and variables obsolete since Emacs 24 have been removed: +'default-directory-alist', 'dired-default-directory', +'dired-default-directory-alist', 'dired-enable-local-variables', +'dired-hack-local-variables', 'dired-local-variables-file', +'dired-omit-here-always'. + +** Garbage collection no longer treats miscellaneous objects specially; +they are now allocated like any other pseudovector. As a result, the +'garbage-collect' and 'memory-use-count' functions no longer return a +'misc' component, and the 'misc-objects-consed' variable has been +removed. + +** Reversed character ranges are no longer permitted in 'rx'. +Previously, ranges where the starting character is greater than the +ending character were silently omitted. +For example, '(rx (any "@z-a" (?9 . ?0)))' would match '@' only. +Now, such 'rx' expressions generate an error. + +** Internal 'rx' functions and variables have been removed, +as a consequence of an improved implementation. Packages using +these should use the public 'rx' and 'rx-to-string' instead. +'rx-constituents' is still available for compatibility, but the new +extension mechanism is preferred: 'rx-define', 'rx-let' and +'rx-let-eval'. + +** 'text-mode' no longer sets the value of 'indent-line-function'. +The global value of 'indent-line-function', which defaults to +'indent-relative', will no longer be reset locally when turning on +'text-mode'. + +To get back the old behavior, add a function to 'text-mode-hook' which +performs '(setq-local indent-line-function #'indent-relative)'. + +** 'make-process' no longer accepts a non-nil ':stop' key. This has +never worked reliably, and now causes an error. + +** 'eventp' no longer returns non-nil for lists whose car is nil. +This is consistent with the fact that nil, though a symbol, is not a +valid event type. + +** The obsolete package xesam.el (since Emacs 24) has been removed. + +** The XBM image handler now accepts a ':stride' argument, which should +be specified in image specs representing the entire bitmap as a single +bool vector. + +** 'regexp-quote' may return its argument string. +If the argument needs no quoting, it can be returned instead of a copy. + +** Mouse scroll up and down with control key modifier changes font size. +Previously, the control key modifier was used to scroll up or down by +an amount which was close to near a full screen. This is now instead +available by scrolling with the meta modifier key. + +To get the old behavior back, customize the user option +'mouse-wheel-scroll-amount', or add the following to your init file: + +(customize-set-variable 'mouse-wheel-scroll-amount + '(5 ((shift) . 1) ((control) . nil))) + +By default, the font size will be changed in the window that the mouse +pointer is over. To change this behavior, you can customize the user +option 'mouse-wheel-follow-mouse'. Note that this will also affect +scrolling. + +** Mouse scroll up and down with control key modifier also works on images +where it scales the image under the mouse pointer. + +** 'help-follow-symbol' now signals 'user-error' if point (or the +position pointed to by the argument POS) is not in a symbol. + +** The options.el library has been removed. +It was obsolete since Emacs 22.1, replaced by customize. + +** The tls.el and starttls.el libraries are now marked obsolete. +Use of built-in libgnutls based functionality (described in the Emacs +GnuTLS manual) is recommended instead. + +** The url-ns.el library is now marked obsolete. +This library is used to open configuration files for the long defunct +web browser Netscape, and is no longer relevant. + + +* Lisp Changes in Emacs 27.1 + +** Emacs Lisp integers can now be of arbitrary size. +Emacs uses the GNU Multiple Precision (GMP) library to support +integers whose size is too large to support natively. The integers +supported natively are known as "fixnums", while the larger ones are +"bignums". The new predicates 'bignump' and 'fixnump' can be used to +distinguish between these two types of integers. + +All the arithmetic, comparison, and logical (a.k.a. "bitwise") +operations where bignums make sense now support both fixnums and +bignums. However, note that unlike fixnums, bignums will not compare +equal with 'eq', you must use 'eql' instead. (Numerical comparison +with '=' works on both, of course.) + +Since large bignums consume a lot of memory, Emacs limits the size of +the largest bignum a Lisp program is allowed to create. The +nonnegative value of the new variable 'integer-width' specifies the +maximum number of bits allowed in a bignum. Emacs signals an integer +overflow error if this limit is exceeded. + +Several primitive functions formerly returned floats or lists of +integers to represent integers that did not fit into fixnums. These +functions now simply return integers instead. Affected functions +include functions like 'encode-char' that compute code-points, functions +like 'file-attributes' that compute file sizes and other attributes, +functions like 'process-id' that compute process IDs, and functions like +'user-uid' and 'group-gid' that compute user and group IDs. + +** 'overflow-error' is now documented as a subcategory of 'range-error'. +Formerly it was undocumented, and was (incorrectly) a subcategory +of 'domain-error'. + +** Time values + +*** New function 'time-convert' converts Lisp time values to Lisp +timestamps of various forms, including a new timestamp form '(TICKS +. HZ)' where TICKS is an integer and HZ a positive integer denoting a +clock frequency. + +*** Although the default timestamp format is still '(HI LO US PS)', +it is planned to change in a future Emacs version, to exploit bignums. +The documentation has been updated to mention that the timestamp +format may change and that programs should use functions like +'format-time-string', 'decode-time', and 'time-convert' rather than +probing the innards of a timestamp directly, or creating a timestamp +by hand. + +*** Decoded (calendrical) timestamps now have subsecond resolution. +This affects 'decode-time', which generates these timestamps, as well +as functions like 'encode-time' that accept them. The subsecond info +is present as a '(TICKS . HZ)' value in the seconds element of a +decoded timestamp, and 'decode-time' has a new optional FORM argument +specifying the form of the seconds member. For example, if X is the +timestamp '(1566009571321878186 . 1000000000)', which represents +"2019-08-17 02:39:31.321878186 UTC", '(decode-time X t t)' returns +'((31321878186 . 1000000000) 39 2 17 8 2019 6 nil 0)' instead of the +traditional '(31 39 2 17 8 2019 6 nil 0)' returned by plain +'(decode-time X t)'. Although the default FORM is currently +'integer', which truncates the seconds to an integer and is the +traditional behavior, this default may change in future Emacs +versions, so callers requiring an integer should specify FORM +explicitly. + +*** 'encode-time' supports a new API '(encode-time TIME)'. +The old 'encode-time' API is still supported. + +*** A new package to parse ISO 8601 time, date, durations and +intervals has been added. The main function to use is +'iso8601-parse', but there's also 'iso8601-parse-date', +'iso8601-parse-time', 'iso8601-parse-duration' and +'iso8601-parse-interval'. All these functions return decoded time +structures, except the final one, which returns three of them (start, +end and duration). + +*** 'time-add', 'time-subtract', and 'time-less-p' now accept +infinities and NaNs too, and propagate them or return nil like +floating-point operators do. If both arguments are finite, these +functions now return exact results instead of rounding in some cases, +and they also avoid excess precision when that is easy. + +*** New function 'time-equal-p' compares time values for equality. + +*** 'format-time-string' supports a new conversion specifier flag '+' +that acts like the '0' flag but also puts a '+' before nonnegative +years containing more than four digits. This is for compatibility +with POSIX.1-2017. + +*** To access (or alter) the elements of a decoded time value, the +'decoded-time-second', 'decoded-time-minute', 'decoded-time-hour', +'decoded-time-day', 'decoded-time-month', 'decoded-time-year', +'decoded-time-weekday', 'decoded-time-dst' and 'decoded-time-zone' +accessors can be used. + +*** The new functions 'date-days-in-month' (which will say how many +days there are in a month in a specific year), 'date-ordinal-to-time' +(that computes the date of an ordinal day), 'decoded-time-add' (for +doing computations on a decoded time structure), 'make-decoded-time' +(for making a decoded time structure with only the given keywords +filled out), and 'encoded-time-set-defaults' (which fills in nil +elements as if it's midnight January 1st, 1970) have been added. + +*** In the DST slot, 'encode-time' and 'parse-time-string' now return -1 +if it is not known whether daylight saving time is in effect. +Formerly they were inconsistent: 'encode-time' returned t in this +situation, whereas 'parse-time-string' returned nil. Now they +consistently use nil to mean that DST is not in effect, and use -1 +to mean that it is not known whether DST is in effect. + +** New macro 'benchmark-progn'. +This macro works like 'progn', but messages how long it takes to +evaluate the body forms. The value of the last form is the return +value. + +** New function 'read-char-from-minibuffer'. +This function works like 'read-char', but uses 'read-from-minibuffer' +to read a character, so it maintains a history that can be navigated +via usual minibuffer keystrokes 'M-p'/'M-n'. + +** New variables 'set-message-function' and 'clear-message-function' +can be used to specify functions to show and clear messages that +normally are displayed in the echo area. + +** 'setq-local' can now set an arbitrary number of variables, which +makes the syntax more like 'setq'. + +** 'reveal-mode' can now also be used for more than to toggle between +invisible and visible: It can also toggle 'display' properties in +overlays. This is only done on 'display' properties that have the +'reveal-toggle-invisible' property set. + +** 'process-contact' now takes an optional NO-BLOCK argument to allow +not waiting for a process to be set up. + +** New variable 'read-process-output-max' controls sub-process throughput. +This variable determines how many bytes can be read from a sub-process +in one read operation. The default, 4096 bytes, was previously a +hard-coded constant. Setting it to a larger value might enhance +throughput of reading from sub-processes that produces vast +(megabytes) amounts of data in one go. + +** The new user option 'quit-window-hook' is now run first when +executing the 'quit-window' command. + +** The user options 'help-enable-completion-auto-load', +'help-enable-auto-load' and 'vhdl-project-auto-load', as well as the +function 'vhdl-auto-load-project' have been renamed to have "autoload" +without the hyphen in their names. Obsolete aliases from the old +names have been added. + +** Buttons (created with 'make-button' and related functions) can +now use the 'button-data' property. If present, the data in this +property will be passed on to the 'action' function instead of the +button itself in 'button-activate'. + +** 'defcustom' now takes a ':local' keyword that can be either t or +'permanent', which mean that the variable should be automatically +buffer-local. 'permanent' also sets the variable's 'permanent-local' +property. + +** The new macro 'with-suppressed-warnings' can be used to suppress +specific byte-compile warnings. + +** The new macro 'ignore-error' is like 'ignore-errors', but takes a +specific error condition, and will only ignore that condition. (This +can also be a list of conditions.) + +** The new function 'byte-compile-info-message' can be used to output +informational messages that look pleasing during the Emacs build. + +** New 'help-fns-describe-variable-functions' hook. +It makes it possible to add metadata information to 'describe-variable'. + +** i18n (internationalization) + +*** 'ngettext' can be used now to return the right plural form +according to the given numeric value. + +** 'inhibit-null-byte-detection' is renamed to 'inhibit-nul-byte-detection'. + +** 'self-insert-command' takes the char to insert as (optional) argument. + +** 'lookup-key' can take a list of keymaps as argument. + +** 'condition-case' now accepts t to match any error symbol. + +** New function 'proper-list-p'. +Given a proper list as argument, this predicate returns its length; +otherwise, it returns nil. 'format-proper-list-p' is now an obsolete +alias for the new function. + +** 'define-minor-mode' automatically documents the meaning of ARG. + +** The function 'recenter' now accepts an additional optional argument. +By default, calling 'recenter' will not redraw the frame even if +'recenter-redisplay' is non-nil. Call 'recenter' with the new second +argument non-nil to force redisplay per 'recenter-redisplay's value. + +** New functions 'major-mode-suspend' and 'major-mode-restore'. +Use them when switching temporarily to another major mode, e.g. for +'hexl-mode', or to switch between 'c-mode' and 'image-mode' in XPM. + +** New macro 'dolist-with-progress-reporter'. +This works like 'dolist', but reports progress similar to +'dotimes-with-progress-reporter'. + +** New hook 'after-delete-frame-functions'. +This works like 'delete-frame-functions', but runs after the frame to +be deleted has been made dead and removed from the frame list. + +** The function 'provided-mode-derived-p' was extended to support aliases. +The function now returns non-nil when the argument MODE is derived +from any alias of any of MODES. + +** New frame focus state inspection interface. +The hooks 'focus-in-hook' and 'focus-out-hook' are now obsolete. +Instead, attach to 'after-focus-change-function' using 'add-function' +and inspect the focus state of each frame using 'frame-focus-state'. + +** Emacs now requests and recognizes focus-change notifications from TTYs. +On terminal emulators that support the feature, Emacs can now support +'focus-in-hook' and 'focus-out-hook' for TTY frames. + +** Window-specific face remapping. +Face specifications (of the kind used in 'face-remapping-alist') +now support filters, allowing faces to vary between different windows +displaying the same buffer. See the node "(elisp) Face Remapping" +of the Emacs Lisp Reference manual for more detail. + +** Window change functions have been redesigned. +Hooks reacting to window changes run now only when redisplay detects +that a change has actually occurred. Six hooks are now provided: +'window-buffer-change-functions' (run after window buffers have +changed), 'window-size-change-functions' (run after a window was +assigned a new buffer or size), 'window-configuration-change-hook' +(like the former but run also when a window was deleted), +'window-selection-change-functions' (run when the selected window +changed) and 'window-state-change-functions' and +'window-state-change-hook' (run when any of the preceding ones is +run). Applications can enforce running the latter two using the new +function 'set-frame-window-state-change'. 'window-scroll-functions' +are unaffected by these changes. + +In addition, a number of functions now allow the caller to detect what +has changed since last redisplay: 'window-old-buffer' returns for any +window the buffer it showed at that time. 'old-selected-window' and +'old-selected-frame' return the window and frame that were selected +during last redisplay. 'window-old-pixel-width' (renamed from +'window-pixel-width-before-size-change'), 'window-old-pixel-height' +(renamed from 'window-pixel-height-before-size-change'), +'window-old-body-pixel-width' and 'window-old-body-pixel-height' +return the total and body sizes of any window during last redisplay. + +Also 'run-window-configuration-change-hook' is declared obsolete. + +See the section "(elisp) Window Hooks" in the Elisp manual for a +detailed explanation of the new behavior. + +** Scroll bar and fringe settings can now be made persistent for windows. +The functions 'set-window-scroll-bars' and 'set-window-fringes' now +have a new optional argument that makes the settings they produce +reliably survive subsequent invocations of 'set-window-buffer'. + +** New user option 'resize-mini-frames'. +This option allows automatically resizing minibuffer-only frames +similarly to how minibuffer windows are resized on "normal" frames. + +** New buffer display action function 'display-buffer-in-direction'. +This function allows specifying the location of the window chosen by +'display-buffer' in various ways. + +** New buffer display action alist entry 'dedicated'. +Such an entry allows specifying the dedicated status of a window +created by 'display-buffer'. + +** New buffer display action alist entry 'window-min-height'. +Such an entry allows specifying a minimum height of the window used +for displaying a buffer. 'display-buffer-below-selected' is the only +action function to respect it at the moment. + +** New buffer display action alist entry 'direction'. +This entry is used to specify the location of the window chosen by +'display-buffer-in-direction'. + +** Additional meaning of display action alist entry 'window'. +A 'window' entry can now also specify a reference window for +'display-buffer-in-direction'. + +** The function 'assoc-delete-all' now takes an optional predicate argument. + +** New function 'string-distance' to calculate the Levenshtein distance +between two strings. + +** 'print-quoted' now defaults to t, so if you want to see +'(quote x)' instead of 'x you will have to bind it to nil where applicable. + +** Numbers formatted via '%o' or '%x' are now formatted as signed integers. +This avoids problems in calls like '(read (format "#x%x" -1))', and is +more compatible with bignums. To get the traditional machine-dependent +behavior, set the experimental variable 'binary-as-unsigned' to t, +and if the new behavior breaks your code please email +<32252@debbugs.gnu.org>. Because '%o' and '%x' can now format signed +integers, they now support the '+' and space flags. + +** In Emacs Lisp mode, symbols with confusable quotes are highlighted. +For example, the first character in '‘foo' would be highlighted in +'font-lock-warning-face'. + +** Omitting variables after '&optional' and '&rest' is now allowed. +For example '(defun foo (&optional))' is no longer an error. This is +sometimes convenient when writing macros. See the ChangeLog entry +titled "Allow '&rest' or '&optional' without following variable +(Bug#29165)" for a full listing of which arglists are accepted across +versions. + +** Internal parsing commands now use 'syntax-ppss' and disregard +'open-paren-in-column-0-is-defun-start'. This affects mostly things like +'forward-comment', 'scan-sexps', and 'forward-sexp' when parsing backward. +The new variable 'comment-use-syntax-ppss' can be set to nil to recover +the old behavior if needed. +This also means that there is no longer any need to precede opening +brackets at the start of a line inside documentation strings with a +backslash, although there is no harm in doing so to make the code +easier to edit with an older Emacs version. + +** New symbolic accessor functions for a parse state list. +The new accessor functions 'ppss-depth', 'ppss-list-start', +'ppss-last-sexp-start', 'ppss-string-terminator', 'comment-depth', +'quoted-p', 'comment-style', 'comment-or-string-start', 'open-parens', +and 'two-character-syntax' can be used on the list value returned by +'parse-partial-sexp' and 'syntax-ppss'. + +** The 'server-name' and 'server-socket-dir' variables are set when a +socket has been passed to Emacs. + +** The 'file-system-info' function is now available on all platforms. +instead of just Microsoft platforms. This fixes a 'get-free-disk-space' +bug on OS X 10.8 and later. + +** The function 'get-free-disk-space' returns now a non-nil value for +remote systems, which support this check. + +** 'memory-limit' now returns a better estimate of memory consumption. + +** When interpreting 'gc-cons-percentage', Emacs now estimates the +heap size more often and (we hope) more accurately. E.g., formerly +'(progn (let ((gc-cons-percentage 0.8)) BODY1) BODY2)' continued to use +the 0.8 value during BODY2 until the next garbage collection, but that +is no longer true. Applications may need to re-tune their GC tricks. + +** New macro 'combine-change-calls' arranges to call the change hooks +('before-change-functions' and 'after-change-functions') just once +each around a sequence of lisp forms, given a region. This is +useful when a function makes a possibly large number of repetitive +changes and the change hooks are time consuming. + +** 'eql', 'make-hash-table', etc. now treat NaNs consistently. +Formerly, some of these functions ignored signs and significands of +NaNs. Now, all these functions treat NaN signs and significands as +significant. For example, '(eql 0.0e+NaN -0.0e+NaN)' now returns nil +because the two NaNs have different signs; formerly it returned t. +Also, Emacs now reads and prints NaN significands; e.g., if X is a +NaN, '(format "%s" X)' now returns "0.0e+NaN", "1.0e+NaN", etc., +depending on X's significand. + +** The function 'make-string' accepts an additional optional argument. +If the optional third argument is non-nil, 'make-string' will produce +a multibyte string even if its second argument is an ASCII character. + +** '(format "%d" X)' no longer mishandles a floating-point number X that +does not fit in a machine integer. + +** New coding-system 'ibm038'. +This is the International EBCDIC encoding, also available as aliases +'ebcdic-int' and 'cp038'. + +** New JSON parsing and serialization functions 'json-serialize', +'json-insert', 'json-parse-string', and 'json-parse-buffer'. These +are implemented in C using the Jansson library. + +** New function 'ring-resize'. +'ring-resize' can be used to grow or shrink a ring. + +** New function 'flatten-tree'. +'flatten-list' is provided as an alias. These functions take a tree +and 'flatten' it such that the result is a list of all the terminal +nodes. + +** 'zlib-decompress-region' can partially decompress corrupted data. +If the new optional ALLOW-PARTIAL argument is passed, then the data +that was decompressed successfully before failing will be inserted +into the buffer. + +** Image mode + +*** New library Exif. +An Exif library has been added that can parse JPEG files and output +data about creation times and orientation and the like. +'exif-parse-file' and 'exif-parse-buffer' are the main interface +functions. + +*** 'image-mode' now uses this library to automatically rotate images +according to the orientation in the Exif data, if any. + +*** The command 'image-rotate' now accepts a prefix argument. +With a prefix argument, 'image-rotate' now rotates the image at point +90 degrees counter-clockwise, instead of the default clockwise. + +*** In 'image-mode' the image is resized automatically to fit in window. +By default, the image will resize upon first display and whenever the +window's dimensions change. Two user options 'image-auto-resize' and +'image-auto-resize-on-window-resize' control the resizing behavior +(including the possibility to disable auto-resizing). A new prefix +key 's' contains the commands that can be used to fit the image to the +window manually. + +*** Some 'image-mode' variables are now buffer-local. +The image parameters 'image-transform-rotation', +'image-transform-scale' and 'image-transform-resize' are now declared +buffer-local, so each buffer could have its own values for these +parameters. + +*** Three new 'image-mode' commands have been added: 'm', which marks +the file in the dired buffer(s) for the directory the file is in; 'u', +which unmarks the file; and 'w', which pushes the current buffer's file +name to the kill ring. + +*** New library image-converter. +If you need to view exotic image formats for which Emacs doesn't have +native support, customize the new user option +'image-use-external-converter' to t. If your system has +GraphicsMagick, ImageMagick or 'ffmpeg' installed, they will then be +used to convert images automatically before displaying them. + +*** 'auto-mode-alist' now includes many of the types typically +supported by the external image converters, like WEPB, BMP and ICO. +These now default to using 'image-mode'. + +*** 'imagemagick-types-inhibit' disables using ImageMagick by default. +'image-mode' started using ImageMagick by default for all images +some years back. It now respects 'imagemagick-types-inhibit' as a way +to disable that. + +** Modules + +*** The function 'load' now behaves correctly when loading modules. +Specifically, it puts the module name into 'load-history', prints +loading messages if requested, and protects against recursive loads. + +*** New module environment function 'process_input' to process user +input while module code is running. + +*** New module environment functions 'make_time' and 'extract_time' to +convert between timespec structures and Emacs Lisp time values. + +*** New module environment functions 'make_big_integer' and +'extract_big_integer' to create and extract arbitrary-size integer +values. + +*** emacs-module.h now defines a macro 'EMACS_MAJOR_VERSION' that expands +to the major version of the latest Emacs supported by the header. + +** The function 'read-variable' now uses its own history list. +The history of variable names read by 'read-variable' is recorded in +the new variable 'custom-variable-history'. + +** The functions 'string-to-unibyte' and 'string-to-multibyte' are no +longer declared obsolete. We have found that there are legitimate use +cases for these functions, where there's no better alternative. We +believe that the incorrect uses of these functions all but disappeared +by now, so we are un-obsoleting them. + +** New function 'group-name' returns a group name corresponding to GID. + +** 'make-process' now takes a keyword argument ':file-handler'; if +that is non-nil, it will look for a file name handler for the current +buffer's 'default-directory' and invoke that file name handler to make +the process. That way 'make-process' can start remote processes. + +** '(locale-info 'paper)' now returns the paper size on systems that support it. +This is currently supported on GNUish hosts and on modern versions of +MS-Windows. + +** The function 'regexp-opt', when given an empty list of strings, now +returns a regexp that never matches anything, which is an identity for +this operation. Previously, the empty string was returned in this +case. + +** New constant 'regexp-unmatchable' contains a never-matching regexp. +It is a convenient and readable way to specify a regexp that should +not match anything, and is as fast as any such regexp can be. + +** New functions to handle the URL variant of base-64 encoding. +New functions 'base64url-encode-string' and 'base64url-encode-region' +implement the url-variant of base-64 encoding as defined in RFC4648. + +The functions 'base64-decode-string' and 'base64-decode-region' now +accept an optional argument to decode the URL variant of base-64 +encoding. + +** The function 'file-size-human-readable' accepts more optional arguments. +The new third argument is a string put between the number and unit; it +defaults to the empty string. The new fourth argument is a string +representing the unit to use; it defaults to "B" when the second +argument is 'iec' and the empty string otherwise. We recommend a +space or non-breaking space as third argument, and "B" as fourth +argument, circumstances allowing. + +** 'format-spec' has been expanded with several modifiers to allow +greater flexibility when customizing variables. The modifiers include +zero-padding, upper- and lower-casing, and limiting the length of the +interpolated strings. The function has now also been documented in +the Emacs Lisp manual. + +** 'directory-files-recursively' can now take an optional PREDICATE +parameter to control descending into subdirectories, and a +FOLLOW-SYMLINK parameter to say that symbolic links that point to +other directories should be followed. + +** New function 'xor' returns the boolean exclusive-or of its args. +The function was previously defined in array.el, but has been moved to +subr.el so that it is available by default. It now always returns the +non-nil argument when the other is nil. Several duplicates of 'xor' +in other packages are now obsolete aliases of 'xor'. + +** 'define-globalized-minor-mode' now takes BODY forms. + +** New text property 'help-echo-inhibit-substitution'. +Setting this on the first character of a help string disables +conversions via 'substitute-command-keys'. + +** New text property 'minibuffer-message'. +Setting this on a character of the minibuffer text will display the +temporary echo messages before that character, when messages need to +be displayed while minibuffer is active. + +** 'undo' can be made to ignore the active region for a command +by setting 'undo-inhibit-region' symbol property of that command to +non-nil. This is used by 'mouse-drag-region' to make the effect +easier to undo immediately afterwards. + +** When called interactively, 'next-buffer' and 'previous-buffer' now +signal 'user-error' if there is no buffer to switch to. + + +* Changes in Emacs 27.1 on Non-Free Operating Systems + +** Battery status is now supported in all Cygwin builds. +Previously it was supported only in the Cygwin-w32 build. + +** Emacs now handles key combinations involving the macOS "command" +and "option" modifier keys more correctly. + +** MacOS modifier key behavior is now more adjustable. +The behavior of the macOS "Option", "Command", "Control" and +"Function" keys can now be specified separately for use with +ordinary keys, function keys and mouse clicks. This allows using them +in their standard macOS way for composing characters. + +** The special handling of 'frame-title-format' on NS where setting it +to t would enable the macOS proxy icon has been replaced with a +separate variable, 'ns-use-proxy-icon'. 'frame-title-format' will now +work as on other platforms. + +** New primitive 'w32-read-registry'. +This primitive lets Lisp programs access the MS-Windows Registry by +retrieving values stored under a given key. It is intended to be used +for supporting features such as XDG-like location of important files +and directories. + +** The default value of 'w32-pipe-read-delay' is now zero. +This speeds up reading output from sub-processes that produce a lot of +data. + +This variable may need to be non-zero only when running DOS programs +as Emacs subprocesses, which by now is not supported on modern +versions of MS-Windows. Set this variable to 50 if for some reason +you need the old behavior (and please report such situations to Emacs +developers). + +** New variable 'w32-multibyte-code-page'. +This variable holds the value of the multibyte code page used by the +system. It is usually zero, which indicates that 'w32-ansi-code-page' +is being used, except in Far Eastern locales. When this variable is +non-zero, Emacs at startup sets 'locale-coding-system' to the +corresponding encoding, instead of using 'w32-ansi-code-page'. + +** The default value of 'inhibit-compacting-font-caches' is t on MS-Windows. +Experience shows that compacting font caches causes more trouble on +MS-Windows than it helps. + +** Font lookup on MS-Windows was improved to support rare scripts. +To activate the improvement, run the new function +'w32-find-non-USB-fonts' once per Emacs session, or assign to the new +variable 'w32-non-USB-fonts' the list of scripts and the corresponding +fonts. See the documentation of this function and variable in the +Emacs manual for more details. + +** On NS the behavior of drag and drop can now be modified by use of +modifier keys in line with Apples guidelines. This makes the drag and +drop behavior more consistent, as previously the sending application +was able to 'set' modifiers without the knowledge of the user. + +** On NS multicolor font display is enabled again since it is also +implemented in Emacs on free operating systems via Cairo drawing. + + +---------------------------------------------------------------------- +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or +(at your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + + +Local variables: +coding: utf-8 +mode: outline +paragraph-separate: "[ ]*$" +end: diff --git a/etc/PROBLEMS b/etc/PROBLEMS index 12cfbd0de2f..4ce738d9a54 100644 --- a/etc/PROBLEMS +++ b/etc/PROBLEMS @@ -318,6 +318,83 @@ element from LD_LIBRARY_PATH before starting emacs proper. Or you could recompile Emacs with an -Wl,-rpath option that gives the location of the correct libotf. +* Problems when reading or debugging Emacs C code + +Because Emacs does not install a copy of its C source code, users +normally cannot easily read that code via commands like 'M-x +describe-function' (C-h f) that display the definition of a function. +However, some GNU/Linux systems provide separate packages containing +this source code which can get C-h f to work if you are willing to do +some tinkering, and some systems also provide packages containing +debug info, which when combined with the source can be used to debug +Emacs at the C level. + +** Debian-based source and debuginfo + +On recent Debian-based systems, you can obtain and use a source +package of Emacs as follows. + +*** Add the appropriate URI to /etc/apt/sources.list. + +To do this, become superuser and uncomment or add the appropriate +'deb-src' line. Details depend on the distribution. + +*** Execute a command like 'apt-get source emacs'. + +On older systems, append the top-level version number, e.g., 'apt-get +source emacs25'. The target directory for unpacking the source tree +is the current directory. + +*** Set find-function-C-source-directory accordingly. + +Once you have installed the source package, for example at +/home/myself/deb-src/emacs-26.3, add the following line to your +startup file: + + (setq find-function-C-source-directory + "/home/myself/deb-src/emacs-26.3/src/") + +The installation directory of the Emacs source package will contain +the exact package name and version number of Emacs that is installed +on your system. If a new Emacs package is installed, the source +package must be reinstalled as well, and the setting in your startup +file must be updated. + +*** Debian-based debuginfo + +You can also install a debug package of Emacs with a command like +'apt-get install emacs-dbg' (on older systems, 'apt-get install +emacs25-dbg'). You need to arrange for GDB to find where you +installed the source code, e.g., by using GDB's 'directory' command. + +** Red Hat-based source and debuginfo + +On recent Red Hat-based systems, you can install source and debug info +via superuser commands like the following: + + # Add the *-debuginfo repositories (exact command depends on system). + dnf config-manager --set-enabled fedora-debuginfo updates-debuginfo' + + # Install Emacs source and debug info. + dnf install emacs-debugsource + +To get describe-function and similar commands to work, you can then +add something like the following to your startup file: + + (setq find-function-C-source-directory + "/usr/src/debug/emacs-26.3-1.fc31.x86_64/src/") + +However, the exact directory name will depend on the system, and you +will need to both upgrade source and debug info when your system +upgrades or patches Emacs, and change your startup file accordingly. + +** Source and debuginfo for other systems + +If your system follows neither the Debian nor the Red Hat patterns, +you can obtain the source and debuginfo by obtaining the source code +of Emacs, building Emacs with the appropriate debug flags enabled, and +running the just-built Emacs. + * General runtime problems ** Lisp problems @@ -2647,15 +2724,6 @@ If you do, please send it to bug-gnu-emacs@gnu.org so we can list it here. Libxpm is available for macOS as part of the XQuartz project. -** The color list can become corrupt. - -This can be seen when Emacs is run from the command line and produces -output containing the text: - - non-keyed archive cannot be decoded by NSKeyedUnarchiver - -The solution is to delete '$HOME/Library/Colors/Emacs.clr'. - * Build-time problems diff --git a/etc/compilation.txt b/etc/compilation.txt index ebce6a14d06..8f7e2906787 100644 --- a/etc/compilation.txt +++ b/etc/compilation.txt @@ -237,6 +237,20 @@ Register 6 contains wrong type ==1332== by 0x8008621: main (vtest.c:180) +* javac Java compiler + +symbol: javac + +Should also work when compiling Java with Gradle. We use the position +of "^" in the third line as column number because no explicit value is +present. + +Test.java:5: error: ';' expected + foo foo + ^ +1 error + + * IBM jikes symbols: jikes-file jikes-line diff --git a/etc/edt-user.el b/etc/edt-user.el index 0ecd818ec78..2852f936f22 100644 --- a/etc/edt-user.el +++ b/etc/edt-user.el @@ -1,4 +1,4 @@ -;;; edt-user.el --- Sample user customizations for Emacs EDT emulation +;;; edt-user.el --- Sample user customizations for Emacs EDT emulation -*- lexical-binding: t -*- ;; Copyright (C) 1986, 1992-1993, 2000-2020 Free Software Foundation, ;; Inc. diff --git a/etc/forms/forms-d2.el b/etc/forms/forms-d2.el index 67cdb9cd010..1b0d6426e03 100644 --- a/etc/forms/forms-d2.el +++ b/etc/forms/forms-d2.el @@ -1,4 +1,4 @@ -;;; forms-d2.el --- demo forms-mode +;;; forms-d2.el --- demo forms-mode -*- lexical-binding:t -*- ;; Copyright (C) 1991, 1994-1997, 2001-2020 Free Software Foundation, ;; Inc. diff --git a/etc/forms/forms-pass.el b/etc/forms/forms-pass.el index 34d4548434b..0f4ab48247e 100644 --- a/etc/forms/forms-pass.el +++ b/etc/forms/forms-pass.el @@ -1,4 +1,4 @@ -;;; forms-pass.el --- passwd file demo for forms-mode +;;; forms-pass.el --- passwd file demo for forms-mode -*- lexical-binding:t -*- ;; This file is part of GNU Emacs. diff --git a/etc/refcards/ru-refcard.tex b/etc/refcards/ru-refcard.tex index ffa073f3da7..0d210b45452 100644 --- a/etc/refcards/ru-refcard.tex +++ b/etc/refcards/ru-refcard.tex @@ -40,7 +40,7 @@ \newlength{\ColThreeWidth} \setlength{\ColThreeWidth}{25mm} -\newcommand{\versionemacs}[0]{27} % version of Emacs this is for +\newcommand{\versionemacs}[0]{28} % version of Emacs this is for \newcommand{\cyear}[0]{2020} % copyright year \newcommand\shortcopyrightnotice[0]{\vskip 1ex plus 2 fill diff --git a/etc/srecode/el.srt b/etc/srecode/el.srt index 3473fb693c1..7d5c64c86c0 100644 --- a/etc/srecode/el.srt +++ b/etc/srecode/el.srt @@ -102,7 +102,7 @@ $<MODEFCN:declaration:function$ comment-start ";;" comment-end "") (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (set-syntax-table $MODESYM$-mode-syntax-table) (use-local-map $MODESYM$-mode-map) (set (make-local-variable 'font-lock-defaults) diff --git a/etc/themes/adwaita-theme.el b/etc/themes/adwaita-theme.el index dd886ea0c19..67a3b11763c 100644 --- a/etc/themes/adwaita-theme.el +++ b/etc/themes/adwaita-theme.el @@ -1,4 +1,4 @@ -;;; adwaita-theme.el --- Tango-based custom theme for faces +;;; adwaita-theme.el --- Tango-based custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. diff --git a/etc/themes/deeper-blue-theme.el b/etc/themes/deeper-blue-theme.el index 8dfe9e3617a..2557918ed7e 100644 --- a/etc/themes/deeper-blue-theme.el +++ b/etc/themes/deeper-blue-theme.el @@ -1,4 +1,4 @@ -;;; deeper-blue-theme.el --- Custom theme for faces +;;; deeper-blue-theme.el --- Custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. @@ -68,7 +68,6 @@ `(font-lock-comment-face ((,class (:foreground "gray50")))) `(font-lock-constant-face ((,class (:foreground "DarkOliveGreen3")))) `(font-lock-doc-face ((,class (:foreground "moccasin")))) - `(font-lock-doc-string-face ((,class (:foreground "moccasin")))) `(font-lock-function-name-face ((,class (:foreground "goldenrod")))) `(font-lock-keyword-face ((,class (:foreground "DeepSkyBlue1")))) `(font-lock-preprocessor-face ((,class (:foreground "gold")))) diff --git a/etc/themes/dichromacy-theme.el b/etc/themes/dichromacy-theme.el index ac862bc4338..89b5a4e4525 100644 --- a/etc/themes/dichromacy-theme.el +++ b/etc/themes/dichromacy-theme.el @@ -1,4 +1,4 @@ -;;; dichromacy-theme.el --- color theme suitable for color-blind users +;;; dichromacy-theme.el --- color theme suitable for color-blind users -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/etc/themes/leuven-theme.el b/etc/themes/leuven-theme.el index 4d8568b7d8f..c298b536d2d 100644 --- a/etc/themes/leuven-theme.el +++ b/etc/themes/leuven-theme.el @@ -1,10 +1,10 @@ -;;; leuven-theme.el --- Awesome Emacs color theme on white background +;;; leuven-theme.el --- Awesome Emacs color theme on white background -*- lexical-binding:t -*- ;; Copyright (C) 2003-2020 Free Software Foundation, Inc. ;; Author: Fabrice Niessen <(concat "fniessen" at-sign "pirilampo.org")> ;; URL: https://github.com/fniessen/emacs-leuven-theme -;; Version: 20170912.2328 +;; Version: 20200425.0837 ;; Keywords: color theme ;; This file is part of GNU Emacs. @@ -130,7 +130,6 @@ Semantic, and Ansi-Color faces are included -- and much more...") `(font-lock-comment-face ((,class (:slant italic :foreground "#8D8D84")))) ; #696969 `(font-lock-constant-face ((,class (:foreground "#D0372D")))) `(font-lock-doc-face ((,class (:foreground "#036A07")))) - ;; `(font-lock-doc-string-face ((,class (:foreground "#008000")))) ; XEmacs only, but is used for HTML exports from org2html (and not interactively) `(font-lock-function-name-face ((,class (:weight normal :foreground "#006699")))) `(font-lock-keyword-face ((,class (:bold nil :foreground "#0000FF")))) ; #3654DC `(font-lock-preprocessor-face ((,class (:foreground "#808080")))) diff --git a/etc/themes/light-blue-theme.el b/etc/themes/light-blue-theme.el index b769015f746..c6d3c92bce7 100644 --- a/etc/themes/light-blue-theme.el +++ b/etc/themes/light-blue-theme.el @@ -1,4 +1,4 @@ -;;; light-blue-theme.el --- Custom theme for faces +;;; light-blue-theme.el --- Custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/etc/themes/manoj-dark-theme.el b/etc/themes/manoj-dark-theme.el index 045d4462843..5c76d6a1e98 100644 --- a/etc/themes/manoj-dark-theme.el +++ b/etc/themes/manoj-dark-theme.el @@ -1,4 +1,4 @@ -;;; manoj-dark.el --- A dark theme from Manoj +;;; manoj-dark.el --- A dark theme from Manoj -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. @@ -88,7 +88,6 @@ jarring angry fruit salad look to reduce eye fatigue.") '(font-lock-comment-face ((t (:italic t :slant oblique :foreground "chocolate1")))) '(font-lock-comment-delimiter-face ((t (:foreground "Salmon")))) '(font-lock-doc-face ((t (:italic t :slant oblique :foreground "LightCoral")))) - '(font-lock-doc-string-face ((t (:foreground "Plum")))) '(font-lock-warning-face ((t (:bold t :foreground "Pink" :weight bold)))) '(cperl-array-face ((t (:foreground "LawnGreen" :background "Black" :bold t)))) diff --git a/etc/themes/misterioso-theme.el b/etc/themes/misterioso-theme.el index b51c9b8e58b..ff9af0c7440 100644 --- a/etc/themes/misterioso-theme.el +++ b/etc/themes/misterioso-theme.el @@ -1,4 +1,4 @@ -;;; misterioso-theme.el --- Custom face theme for Emacs +;;; misterioso-theme.el --- Custom face theme for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/etc/themes/tango-dark-theme.el b/etc/themes/tango-dark-theme.el index 86cc2595ae9..cf1a98bfee2 100644 --- a/etc/themes/tango-dark-theme.el +++ b/etc/themes/tango-dark-theme.el @@ -1,4 +1,4 @@ -;;; tango-dark-theme.el --- Tango-based custom theme for faces +;;; tango-dark-theme.el --- Tango-based custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. diff --git a/etc/themes/tango-theme.el b/etc/themes/tango-theme.el index ab39bbc06fb..6166657c145 100644 --- a/etc/themes/tango-theme.el +++ b/etc/themes/tango-theme.el @@ -1,4 +1,4 @@ -;;; tango-theme.el --- Tango-based custom theme for faces +;;; tango-theme.el --- Tango-based custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. diff --git a/etc/themes/tsdh-dark-theme.el b/etc/themes/tsdh-dark-theme.el index 515a142d284..f3c9ced5b03 100644 --- a/etc/themes/tsdh-dark-theme.el +++ b/etc/themes/tsdh-dark-theme.el @@ -1,4 +1,4 @@ -;;; tsdh-dark-theme.el --- Tassilo's dark custom theme +;;; tsdh-dark-theme.el --- Tassilo's dark custom theme -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/etc/themes/tsdh-light-theme.el b/etc/themes/tsdh-light-theme.el index eaa65ffebd1..46443edfd49 100644 --- a/etc/themes/tsdh-light-theme.el +++ b/etc/themes/tsdh-light-theme.el @@ -1,4 +1,4 @@ -;;; tsdh-light-theme.el --- Tassilo's light custom theme +;;; tsdh-light-theme.el --- Tassilo's light custom theme -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/etc/themes/wheatgrass-theme.el b/etc/themes/wheatgrass-theme.el index c3edced3fa7..f1abdb38952 100644 --- a/etc/themes/wheatgrass-theme.el +++ b/etc/themes/wheatgrass-theme.el @@ -1,4 +1,4 @@ -;;; wheatgrass-theme.el --- custom theme for faces +;;; wheatgrass-theme.el --- custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. diff --git a/etc/themes/whiteboard-theme.el b/etc/themes/whiteboard-theme.el index 853479fa9c4..ee42e4f2155 100644 --- a/etc/themes/whiteboard-theme.el +++ b/etc/themes/whiteboard-theme.el @@ -1,4 +1,4 @@ -;;; whiteboard-theme.el --- Custom theme for faces +;;; whiteboard-theme.el --- Custom theme for faces -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. @@ -48,7 +48,6 @@ `(font-lock-comment-face ((,class (:foreground "gray50")))) `(font-lock-constant-face ((,class (:foreground "DarkOliveGreen4")))) `(font-lock-doc-face ((,class (:foreground "peru")))) - `(font-lock-doc-string-face ((,class (:foreground "peru")))) `(font-lock-function-name-face ((,class (:foreground "goldenrod3")))) `(font-lock-keyword-face ((,class (:foreground "DodgerBlue2")))) `(font-lock-preprocessor-face ((,class (:foreground "gold3")))) diff --git a/etc/themes/wombat-theme.el b/etc/themes/wombat-theme.el index 122d3022221..4df5f5a3f1c 100644 --- a/etc/themes/wombat-theme.el +++ b/etc/themes/wombat-theme.el @@ -1,4 +1,4 @@ -;;; wombat-theme.el --- Custom face theme for Emacs +;;; wombat-theme.el --- Custom face theme for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/lib-src/Makefile.in b/lib-src/Makefile.in index 29b34d9363b..a2d27eab001 100644 --- a/lib-src/Makefile.in +++ b/lib-src/Makefile.in @@ -231,8 +231,6 @@ BASE_CFLAGS = $(C_SWITCH_SYSTEM) $(C_SWITCH_MACHINE) \ -I${srcdir} -I${srcdir}/../src -I${srcdir}/../lib ALL_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${LDFLAGS} ${CPPFLAGS} ${CFLAGS} -## Unused. -LINK_CFLAGS = ${BASE_CFLAGS} ${LDFLAGS} ${CFLAGS} CPP_CFLAGS = ${BASE_CFLAGS} ${PROFILING_CFLAGS} ${CPPFLAGS} ${CFLAGS} # Configuration files for .o files to depend on. diff --git a/lib-src/emacsclient.c b/lib-src/emacsclient.c index 204064f1871..380be95222b 100644 --- a/lib-src/emacsclient.c +++ b/lib-src/emacsclient.c @@ -80,7 +80,7 @@ char *w32_getenv (const char *); #include <sys/stat.h> #include <unistd.h> -#include <dosname.h> +#include <filename.h> #include <intprops.h> #include <min-max.h> #include <pathmax.h> diff --git a/lib-src/etags.c b/lib-src/etags.c index 8babe926db1..146cf612505 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -124,6 +124,7 @@ University of California, as described above. */ #include <binary-io.h> #include <intprops.h> #include <unlocked-io.h> +#include <verify.h> #include <c-ctype.h> #include <c-strcase.h> @@ -4199,9 +4200,9 @@ C_entries (int c_ext, FILE *inf) break; } FALLTHROUGH; - resetfvdef: case '#': case '~': case '&': case '%': case '/': case '|': case '^': case '!': case '.': case '?': + resetfvdef: if (definedef != dnone) break; /* These surely cannot follow a function tag in C. */ @@ -7313,6 +7314,8 @@ static void * xnmalloc (ptrdiff_t nitems, ptrdiff_t item_size) { ptrdiff_t nbytes; + assume (0 <= nitems); + assume (0 < item_size); if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes)) memory_full (); return xmalloc (nbytes); @@ -7322,6 +7325,8 @@ static void * xnrealloc (void *pa, ptrdiff_t nitems, ptrdiff_t item_size) { ptrdiff_t nbytes; + assume (0 <= nitems); + assume (0 < item_size); if (INT_MULTIPLY_WRAPV (nitems, item_size, &nbytes) || SIZE_MAX < nbytes) memory_full (); void *result = realloc (pa, nbytes); diff --git a/lib/_Noreturn.h b/lib/_Noreturn.h index 0d4b9c29e02..394ca3c2aa2 100644 --- a/lib/_Noreturn.h +++ b/lib/_Noreturn.h @@ -28,7 +28,10 @@ # define _Noreturn [[noreturn]] # elif ((!defined __cplusplus || defined __clang__) \ && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ - || 4 < __GNUC__ + (7 <= __GNUC_MINOR__))) + || 4 < __GNUC__ + (7 <= __GNUC_MINOR__) \ + || (defined __apple_build_version__ \ + ? 6000000 <= __apple_build_version__ \ + : 3 < __clang_major__ + (5 <= __clang_minor__)))) /* _Noreturn works as-is. */ # elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C # define _Noreturn __attribute__ ((__noreturn__)) diff --git a/lib/alloca.in.h b/lib/alloca.in.h index 228f9a0a29b..5686b082bbe 100644 --- a/lib/alloca.in.h +++ b/lib/alloca.in.h @@ -1,7 +1,7 @@ /* Memory allocation on the stack. - Copyright (C) 1995, 1999, 2001-2004, 2006-2020 Free Software - Foundation, Inc. + Copyright (C) 1995, 1999, 2001-2004, 2006-2020 Free Software Foundation, + Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published @@ -35,13 +35,16 @@ */ #ifndef alloca + /* Some version of mingw have an <alloca.h> that causes trouble when + included after 'alloca' gets defined as a macro. As a workaround, + include this <alloca.h> first and define 'alloca' as a macro afterwards + if needed. */ +# if defined __GNUC__ && (defined _WIN32 && ! defined __CYGWIN__) && @HAVE_ALLOCA_H@ +# include_next <alloca.h> +# endif +#endif +#ifndef alloca # ifdef __GNUC__ - /* Some version of mingw have an <alloca.h> that causes trouble when - included after 'alloca' gets defined as a macro. As a workaround, include - this <alloca.h> first and define 'alloca' as a macro afterwards. */ -# if (defined _WIN32 && ! defined __CYGWIN__) && @HAVE_ALLOCA_H@ -# include_next <alloca.h> -# endif # define alloca __builtin_alloca # elif defined _AIX # define alloca __alloca diff --git a/lib/at-func.c b/lib/at-func.c index 4a1c909d38e..90022e05787 100644 --- a/lib/at-func.c +++ b/lib/at-func.c @@ -16,7 +16,7 @@ /* written by Jim Meyering */ -#include "dosname.h" /* solely for definition of IS_ABSOLUTE_FILE_NAME */ +#include "filename.h" /* solely for definition of IS_ABSOLUTE_FILE_NAME */ #ifdef GNULIB_SUPPORT_ONLY_AT_FDCWD # include <errno.h> diff --git a/lib/attribute.h b/lib/attribute.h new file mode 100644 index 00000000000..2836b99dad0 --- /dev/null +++ b/lib/attribute.h @@ -0,0 +1,215 @@ +/* ATTRIBUTE_* macros for using attributes in GCC and similar compilers + + Copyright 2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify it + under the terms of the GNU General Public License as published + by the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* Written by Paul Eggert. */ + +/* Provide public ATTRIBUTE_* names for the private _GL_ATTRIBUTE_* + macros used within Gnulib. */ + +/* These attributes can be placed in two ways: + - At the start of a declaration (i.e. even before storage-class + specifiers!); then they apply to all entities that are declared + by the declaration. + - Immediately after the name of an entity being declared by the + declaration; then they apply to that entity only. */ + +#ifndef _GL_ATTRIBUTE_H +#define _GL_ATTRIBUTE_H + + +/* This file defines two types of attributes: + * C2X standard attributes. These have macro names that do not begin with + 'ATTRIBUTE_'. + * Selected GCC attributes; see: + https://gcc.gnu.org/onlinedocs/gcc/Common-Function-Attributes.html + https://gcc.gnu.org/onlinedocs/gcc/Common-Variable-Attributes.html + https://gcc.gnu.org/onlinedocs/gcc/Common-Type-Attributes.html + These names begin with 'ATTRIBUTE_' to avoid name clashes. */ + + +/* =============== Attributes for specific kinds of functions =============== */ + +/* Attributes for functions that should not be used. */ + +/* Warn if the entity is used. */ +/* Applies to: + - function, variable, + - struct, union, struct/union member, + - enumeration, enumeration item, + - typedef, + in C++ also: namespace, class, template specialization. */ +#define DEPRECATED _GL_ATTRIBUTE_DEPRECATED + +/* If a function call is not optimized way, warn with MSG. */ +/* Applies to: functions. */ +#define ATTRIBUTE_WARNING(msg) _GL_ATTRIBUTE_WARNING (msg) + +/* If a function call is not optimized way, report an error with MSG. */ +/* Applies to: functions. */ +#define ATTRIBUTE_ERROR(msg) _GL_ATTRIBUTE_ERROR (msg) + + +/* Attributes for memory-allocating functions. */ + +/* The function returns a pointer to freshly allocated memory. */ +/* Applies to: functions. */ +#define ATTRIBUTE_MALLOC _GL_ATTRIBUTE_MALLOC + +/* ATTRIBUTE_ALLOC_SIZE ((N)) - The Nth argument of the function + is the size of the returned memory block. + ATTRIBUTE_ALLOC_SIZE ((M, N)) - Multiply the Mth and Nth arguments + to determine the size of the returned memory block. */ +/* Applies to: function, pointer to function, function types. */ +#define ATTRIBUTE_ALLOC_SIZE(args) _GL_ATTRIBUTE_ALLOC_SIZE (args) + + +/* Attributes for variadic functions. */ + +/* The variadic function expects a trailing NULL argument. + ATTRIBUTE_SENTINEL () - The last argument is NULL. + ATTRIBUTE_SENTINEL ((N)) - The (N+1)st argument from the end is NULL. */ +/* Applies to: functions. */ +#define ATTRIBUTE_SENTINEL(pos) _GL_ATTRIBUTE_SENTINEL (pos) + + +/* ================== Attributes for compiler diagnostics ================== */ + +/* Attributes that help the compiler diagnose programmer mistakes. + Some of them may also help for some compiler optimizations. */ + +/* ATTRIBUTE_FORMAT ((ARCHETYPE, STRING-INDEX, FIRST-TO-CHECK)) - + The STRING-INDEXth function argument is a format string of style + ARCHETYPE, which is one of: + printf, gnu_printf + scanf, gnu_scanf, + strftime, gnu_strftime, + strfmon, + or the same thing prefixed and suffixed with '__'. + If FIRST-TO-CHECK is not 0, arguments starting at FIRST-TO_CHECK + are suitable for the format string. */ +/* Applies to: functions. */ +#define ATTRIBUTE_FORMAT(spec) _GL_ATTRIBUTE_FORMAT (spec) + +/* ATTRIBUTE_NONNULL ((N1, N2,...)) - Arguments N1, N2,... must not be NULL. + ATTRIBUTE_NONNULL () - All pointer arguments must not be null. */ +/* Applies to: functions. */ +#define ATTRIBUTE_NONNULL(args) _GL_ATTRIBUTE_NONNULL (args) + +/* The function's return value is a non-NULL pointer. */ +/* Applies to: functions. */ +#define ATTRIBUTE_RETURNS_NONNULL _GL_ATTRIBUTE_RETURNS_NONNULL + +/* Warn if the caller does not use the return value, + unless the caller uses something like ignore_value. */ +/* Applies to: function, enumeration, class. */ +#define NODISCARD _GL_ATTRIBUTE_NODISCARD + + +/* Attributes that disable false alarms when the compiler diagnoses + programmer "mistakes". */ + +/* Do not warn if the entity is not used. */ +/* Applies to: + - function, variable, + - struct, union, struct/union member, + - enumeration, enumeration item, + - typedef, + in C++ also: class. */ +#define MAYBE_UNUSED _GL_ATTRIBUTE_MAYBE_UNUSED + +/* The contents of a character array is not meant to be NUL-terminated. */ +/* Applies to: struct/union members and variables that are arrays of element + type '[[un]signed] char'. */ +#define ATTRIBUTE_NONSTRING _GL_ATTRIBUTE_NONSTRING + +/* Do not warn if control flow falls through to the immediately + following 'case' or 'default' label. */ +/* Applies to: Empty statement (;), inside a 'switch' statement. */ +#define FALLTHROUGH _GL_ATTRIBUTE_FALLTHROUGH + + +/* ================== Attributes for debugging information ================== */ + +/* Attributes regarding debugging information emitted by the compiler. */ + +/* Omit the function from stack traces when debugging. */ +/* Applies to: function. */ +#define ATTRIBUTE_ARTIFICIAL _GL_ATTRIBUTE_ARTIFICIAL + +/* Make the entity visible to debuggers etc., even with '-fwhole-program'. */ +/* Applies to: functions, variables. */ +#define ATTRIBUTE_EXTERNALLY_VISIBLE _GL_ATTRIBUTE_EXTERNALLY_VISIBLE + + +/* ========== Attributes that mainly direct compiler optimizations ========== */ + +/* The function does not throw exceptions. */ +/* Applies to: functions. */ +#define ATTRIBUTE_NOTHROW _GL_ATTRIBUTE_NOTHROW + +/* Do not inline the function. */ +/* Applies to: functions. */ +#define ATTRIBUTE_NOINLINE _GL_ATTRIBUTE_NOINLINE + +/* Always inline the function, and report an error if the compiler + cannot inline. */ +/* Applies to: function. */ +#define ATTRIBUTE_ALWAYS_INLINE _GL_ATTRIBUTE_ALWAYS_INLINE + +/* The function does not affect observable state, and always returns a value. + Compilers can omit duplicate calls with the same arguments if + observable state is not changed between calls. (This attribute is + looser than ATTRIBUTE_CONST.) */ +/* Applies to: functions. */ +#define ATTRIBUTE_PURE _GL_ATTRIBUTE_PURE + +/* The function neither depends on nor affects observable state, + and always returns a value. Compilers can omit duplicate calls with + the same arguments. (This attribute is stricter than ATTRIBUTE_PURE.) */ +/* Applies to: functions. */ +#define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST + +/* The function is rarely executed. */ +/* Applies to: functions. */ +#define ATTRIBUTE_COLD _GL_ATTRIBUTE_COLD + +/* If called from some other compilation unit, the function executes + code from that unit only by return or by exception handling, + letting the compiler optimize that unit more aggressively. */ +/* Applies to: functions. */ +#define ATTRIBUTE_LEAF _GL_ATTRIBUTE_LEAF + +/* For struct members: The member has the smallest possible alignment. + For struct, union, class: All members have the smallest possible alignment, + minimizing the memory required. */ +/* Applies to: struct members, struct, union, + in C++ also: class. */ +#define ATTRIBUTE_PACKED _GL_ATTRIBUTE_PACKED + + +/* ================ Attributes that make invalid code valid ================ */ + +/* Attributes that prevent fatal compiler optimizations for code that is not + fully ISO C compliant. */ + +/* Pointers to the type may point to the same storage as pointers to + other types, thus disabling strict aliasing optimization. */ +/* Applies to: types. */ +#define ATTRIBUTE_MAY_ALIAS _GL_ATTRIBUTE_MAY_ALIAS + + +#endif /* _GL_ATTRIBUTE_H */ diff --git a/lib/binary-io.h b/lib/binary-io.h index 64223f16fc2..477b4bf4dd3 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -1,6 +1,5 @@ /* Binary mode I/O. - Copyright (C) 2001, 2003, 2005, 2008-2020 Free Software Foundation, - Inc. + Copyright (C) 2001, 2003, 2005, 2008-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/c++defs.h b/lib/c++defs.h index 7a057633883..3e6aaabc9ce 100644 --- a/lib/c++defs.h +++ b/lib/c++defs.h @@ -301,9 +301,6 @@ _GL_WARN_ON_USE_CXX (func, rettype, parameters_and_attributes, \ "The symbol ::" #func " refers to the system function. " \ "Use " #namespace "::" #func " instead.") -# elif __GNUC__ >= 3 && GNULIB_STRICT_CHECKING -# define _GL_CXXALIASWARN1_2(func,rettype,parameters_and_attributes,namespace) \ - extern __typeof__ (func) func # else # define _GL_CXXALIASWARN1_2(func,rettype,parameters_and_attributes,namespace) \ _GL_EXTERN_C int _gl_cxxalias_dummy diff --git a/lib/c-ctype.h b/lib/c-ctype.h index 42891bb1683..fbd11b34508 100644 --- a/lib/c-ctype.h +++ b/lib/c-ctype.h @@ -5,8 +5,7 @@ <ctype.h> functions' behaviour depends on the current locale set via setlocale. - Copyright (C) 2000-2003, 2006, 2008-2020 Free Software Foundation, - Inc. + Copyright (C) 2000-2003, 2006, 2008-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/c-strcasecmp.c b/lib/c-strcasecmp.c index f660bba73b5..951220f3e29 100644 --- a/lib/c-strcasecmp.c +++ b/lib/c-strcasecmp.c @@ -1,6 +1,5 @@ /* c-strcasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/c-strncasecmp.c b/lib/c-strncasecmp.c index 89df6915840..9ad49191b7f 100644 --- a/lib/c-strncasecmp.c +++ b/lib/c-strncasecmp.c @@ -1,6 +1,5 @@ /* c-strncasecmp.c -- case insensitive string comparator in C locale - Copyright (C) 1998-1999, 2005-2006, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2005-2006, 2009-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/canonicalize-lgpl.c b/lib/canonicalize-lgpl.c index 7d3c710f10f..9f990988393 100644 --- a/lib/canonicalize-lgpl.c +++ b/lib/canonicalize-lgpl.c @@ -51,7 +51,7 @@ # define __realpath realpath # include "pathmax.h" # include "malloca.h" -# include "dosname.h" +# include "filename.h" # if HAVE_GETCWD # if IN_RELOCWRAPPER /* When building the relocatable program wrapper, use the system's getcwd diff --git a/lib/careadlinkat.c b/lib/careadlinkat.c index 197ce8de77f..1aa04363dac 100644 --- a/lib/careadlinkat.c +++ b/lib/careadlinkat.c @@ -1,7 +1,7 @@ /* Read symbolic links into a buffer without size limitation, relative to fd. - Copyright (C) 2001, 2003-2004, 2007, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2001, 2003-2004, 2007, 2009-2020 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -72,23 +72,38 @@ careadlinkat (int fd, char const *filename, SSIZE_MAX < SIZE_MAX ? (size_t) SSIZE_MAX + 1 : SIZE_MAX; char stack_buf[1024]; +#if (defined GCC_LINT || defined lint) && _GL_GNUC_PREREQ (10, 1) + /* Pacify preadlinkat without creating a pointer to the stack + that a broken gcc -Wreturn-local-addr would cry wolf about. See: + https://gcc.gnu.org/bugzilla/show_bug.cgi?id=95044 + This workaround differs from the mainline code, but + no other way to pacify GCC 10.1.0 is known; even an explicit + #pragma does not pacify GCC. When the GCC bug is fixed this + workaround should be limited to the broken GCC versions. */ +# define WORK_AROUND_GCC_BUG_95044 +#endif + if (! alloc) alloc = &stdlib_allocator; - if (! buffer_size) + if (!buffer) { +#ifdef WORK_AROUND_GCC_BUG_95044 + buffer = alloc->allocate (sizeof stack_buf); +#else /* Allocate the initial buffer on the stack. This way, in the common case of a symlink of small size, we get away with a single small malloc() instead of a big malloc() followed by a shrinking realloc(). */ buffer = stack_buf; +#endif buffer_size = sizeof stack_buf; } buf = buffer; buf_size = buffer_size; - do + while (buf) { /* Attempt to read the link into the current buffer. */ ssize_t link_length = preadlinkat (fd, filename, buf, buf_size); @@ -117,19 +132,19 @@ careadlinkat (int fd, char const *filename, if (buf == stack_buf) { - char *b = (char *) alloc->allocate (link_size); + char *b = alloc->allocate (link_size); buf_size = link_size; if (! b) break; - memcpy (b, buf, link_size); - buf = b; + return memcpy (b, buf, link_size); } - else if (link_size < buf_size && buf != buffer && alloc->reallocate) + + if (link_size < buf_size && buf != buffer && alloc->reallocate) { /* Shrink BUF before returning it. */ - char *b = (char *) alloc->reallocate (buf, link_size); + char *b = alloc->reallocate (buf, link_size); if (b) - buf = b; + return b; } return buf; @@ -138,8 +153,8 @@ careadlinkat (int fd, char const *filename, if (buf != buffer) alloc->free (buf); - if (buf_size <= buf_size_max / 2) - buf_size *= 2; + if (buf_size < buf_size_max / 2) + buf_size = 2 * buf_size + 1; else if (buf_size < buf_size_max) buf_size = buf_size_max; else if (buf_size_max < SIZE_MAX) @@ -149,9 +164,8 @@ careadlinkat (int fd, char const *filename, } else break; - buf = (char *) alloc->allocate (buf_size); + buf = alloc->allocate (buf_size); } - while (buf); if (alloc->die) alloc->die (buf_size); diff --git a/lib/careadlinkat.h b/lib/careadlinkat.h index 584cfe9ad8e..a4a37b274d0 100644 --- a/lib/careadlinkat.h +++ b/lib/careadlinkat.h @@ -47,7 +47,7 @@ struct allocator; set errno. */ char *careadlinkat (int fd, char const *filename, - char *buffer, size_t buffer_size, + char *restrict buffer, size_t buffer_size, struct allocator const *alloc, ssize_t (*preadlinkat) (int, char const *, char *, size_t)); diff --git a/lib/cloexec.c b/lib/cloexec.c index 269e6f25f3b..510be3d57ec 100644 --- a/lib/cloexec.c +++ b/lib/cloexec.c @@ -1,7 +1,6 @@ /* cloexec.c - set or clear the close-on-exec descriptor flag - Copyright (C) 1991, 2004-2006, 2009-2020 Free Software Foundation, - Inc. + Copyright (C) 1991, 2004-2006, 2009-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/close-stream.c b/lib/close-stream.c index b1d04a53059..04bc8009a57 100644 --- a/lib/close-stream.c +++ b/lib/close-stream.c @@ -1,7 +1,6 @@ /* Close a stream, with nicer error checking than fclose's. - Copyright (C) 1998-2002, 2004, 2006-2020 Free Software Foundation, - Inc. + Copyright (C) 1998-2002, 2004, 2006-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/count-leading-zeros.h b/lib/count-leading-zeros.h index 2b65cc9eda9..7e88c8cb9d0 100644 --- a/lib/count-leading-zeros.h +++ b/lib/count-leading-zeros.h @@ -30,6 +30,10 @@ _GL_INLINE_HEADER_BEGIN # define COUNT_LEADING_ZEROS_INLINE _GL_INLINE #endif +#ifdef __cplusplus +extern "C" { +#endif + /* Assuming the GCC builtin is BUILTIN and the MSC builtin is MSC_BUILTIN, expand to code that computes the number of leading zeros of the local variable 'x' of type TYPE (an unsigned integer type) and return it @@ -100,7 +104,6 @@ count_leading_zeros_l (unsigned long int x) COUNT_LEADING_ZEROS (__builtin_clzl, _BitScanReverse, unsigned long int); } -#if HAVE_UNSIGNED_LONG_LONG_INT /* Compute and return the number of leading zeros in X. */ COUNT_LEADING_ZEROS_INLINE int count_leading_zeros_ll (unsigned long long int x) @@ -108,6 +111,9 @@ count_leading_zeros_ll (unsigned long long int x) COUNT_LEADING_ZEROS (__builtin_clzll, _BitScanReverse64, unsigned long long int); } + +#ifdef __cplusplus +} #endif _GL_INLINE_HEADER_END diff --git a/lib/count-one-bits.h b/lib/count-one-bits.h index 040776f7466..6c5b75708cf 100644 --- a/lib/count-one-bits.h +++ b/lib/count-one-bits.h @@ -30,29 +30,17 @@ _GL_INLINE_HEADER_BEGIN # define COUNT_ONE_BITS_INLINE _GL_INLINE #endif -/* Expand to code that computes the number of 1-bits of the local - variable 'x' of type TYPE (an unsigned integer type) and return it - from the current function. */ -#define COUNT_ONE_BITS_GENERIC(TYPE) \ - do \ - { \ - int count = 0; \ - int bits; \ - for (bits = 0; bits < sizeof (TYPE) * CHAR_BIT; bits += 32) \ - { \ - count += count_one_bits_32 (x); \ - x = x >> 31 >> 1; \ - } \ - return count; \ - } \ - while (0) +#ifdef __cplusplus +extern "C" { +#endif -/* Assuming the GCC builtin is BUILTIN and the MSC builtin is MSC_BUILTIN, +/* Assuming the GCC builtin is GCC_BUILTIN and the MSC builtin is MSC_BUILTIN, expand to code that computes the number of 1-bits of the local variable 'x' of type TYPE (an unsigned integer type) and return it from the current function. */ #if __GNUC__ > 3 || (__GNUC__ == 3 && __GNUC_MINOR__ >= 4) -# define COUNT_ONE_BITS(BUILTIN, MSC_BUILTIN, TYPE) return BUILTIN (x) +# define COUNT_ONE_BITS(GCC_BUILTIN, MSC_BUILTIN, TYPE) \ + return GCC_BUILTIN (x) #else /* Compute and return the number of 1-bits set in the least @@ -67,14 +55,46 @@ count_one_bits_32 (unsigned int x) return (x >> 8) + (x & 0x00ff); } +/* Expand to code that computes the number of 1-bits of the local + variable 'x' of type TYPE (an unsigned integer type) and return it + from the current function. */ +# define COUNT_ONE_BITS_GENERIC(TYPE) \ + do \ + { \ + int count = 0; \ + int bits; \ + for (bits = 0; bits < sizeof (TYPE) * CHAR_BIT; bits += 32) \ + { \ + count += count_one_bits_32 (x); \ + x = x >> 31 >> 1; \ + } \ + return count; \ + } \ + while (0) + # if 1500 <= _MSC_VER && (defined _M_IX86 || defined _M_X64) /* While gcc falls back to its own generic code if the machine on which it's running doesn't support popcount, with Microsoft's compiler we need to detect and fallback ourselves. */ -# pragma intrinsic __cpuid -# pragma intrinsic __popcnt -# pragma intrinsic __popcnt64 + +# if 0 +# include <intrin.h> +# else + /* Don't pollute the namespace with too many MSVC intrinsics. */ +# pragma intrinsic (__cpuid) +# pragma intrinsic (__popcnt) +# if defined _M_X64 +# pragma intrinsic (__popcnt64) +# endif +# endif + +# if !defined _M_X64 +static inline __popcnt64 (unsigned long long x) +{ + return __popcnt ((unsigned int) (x >> 32)) + __popcnt ((unsigned int) x); +} +# endif /* Return nonzero if popcount is supported. */ @@ -86,25 +106,30 @@ popcount_supported (void) { if (popcount_support < 0) { + /* Do as described in + <https://docs.microsoft.com/en-us/cpp/intrinsics/popcnt16-popcnt-popcnt64> */ int cpu_info[4]; __cpuid (cpu_info, 1); - popcount_support = (cpu_info[2] >> 23) & 1; /* See MSDN. */ + popcount_support = (cpu_info[2] >> 23) & 1; } return popcount_support; } -# define COUNT_ONE_BITS(BUILTIN, MSC_BUILTIN, TYPE) \ - do \ - { \ - if (popcount_supported ()) \ - return MSC_BUILTIN (x); \ - else \ - COUNT_ONE_BITS_GENERIC (TYPE); \ - } \ +# define COUNT_ONE_BITS(GCC_BUILTIN, MSC_BUILTIN, TYPE) \ + do \ + { \ + if (popcount_supported ()) \ + return MSC_BUILTIN (x); \ + else \ + COUNT_ONE_BITS_GENERIC (TYPE); \ + } \ while (0) + # else -# define COUNT_ONE_BITS(BUILTIN, MSC_BUILTIN, TYPE) \ + +# define COUNT_ONE_BITS(GCC_BUILTIN, MSC_BUILTIN, TYPE) \ COUNT_ONE_BITS_GENERIC (TYPE) + # endif #endif @@ -122,13 +147,15 @@ count_one_bits_l (unsigned long int x) COUNT_ONE_BITS (__builtin_popcountl, __popcnt, unsigned long int); } -#if HAVE_UNSIGNED_LONG_LONG_INT /* Compute and return the number of 1-bits set in X. */ COUNT_ONE_BITS_INLINE int count_one_bits_ll (unsigned long long int x) { COUNT_ONE_BITS (__builtin_popcountll, __popcnt64, unsigned long long int); } + +#ifdef __cplusplus +} #endif _GL_INLINE_HEADER_END diff --git a/lib/count-trailing-zeros.h b/lib/count-trailing-zeros.h index 15e85708d18..1eb5fb919f4 100644 --- a/lib/count-trailing-zeros.h +++ b/lib/count-trailing-zeros.h @@ -30,6 +30,10 @@ _GL_INLINE_HEADER_BEGIN # define COUNT_TRAILING_ZEROS_INLINE _GL_INLINE #endif +#ifdef __cplusplus +extern "C" { +#endif + /* Assuming the GCC builtin is BUILTIN and the MSC builtin is MSC_BUILTIN, expand to code that computes the number of trailing zeros of the local variable 'x' of type TYPE (an unsigned integer type) and return it @@ -92,7 +96,6 @@ count_trailing_zeros_l (unsigned long int x) COUNT_TRAILING_ZEROS (__builtin_ctzl, _BitScanForward, unsigned long int); } -#if HAVE_UNSIGNED_LONG_LONG_INT /* Compute and return the number of trailing zeros in X. */ COUNT_TRAILING_ZEROS_INLINE int count_trailing_zeros_ll (unsigned long long int x) @@ -100,6 +103,9 @@ count_trailing_zeros_ll (unsigned long long int x) COUNT_TRAILING_ZEROS (__builtin_ctzll, _BitScanForward64, unsigned long long int); } + +#ifdef __cplusplus +} #endif _GL_INLINE_HEADER_END diff --git a/lib/diffseq.h b/lib/diffseq.h index 16e06053b43..c89363ac9ee 100644 --- a/lib/diffseq.h +++ b/lib/diffseq.h @@ -1,7 +1,7 @@ /* Analyze differences between two vectors. - Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2020 Free - Software Foundation, Inc. + Copyright (C) 1988-1989, 1992-1995, 2001-2004, 2006-2020 Free Software + Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/dirent.in.h b/lib/dirent.in.h index f7c26810158..6fa44f0d28d 100644 --- a/lib/dirent.in.h +++ b/lib/dirent.in.h @@ -57,10 +57,12 @@ typedef struct gl_directory DIR; /* The __attribute__ feature is available in gcc versions 2.5 and later. The attribute __pure__ was added in gcc 2.96. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) -# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) -#else -# define _GL_ATTRIBUTE_PURE /* empty */ +#ifndef _GL_ATTRIBUTE_PURE +# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) +# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) +# else +# define _GL_ATTRIBUTE_PURE /* empty */ +# endif #endif /* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ diff --git a/lib/dosname.h b/lib/dosname.h deleted file mode 100644 index 3bb08a5eeec..00000000000 --- a/lib/dosname.h +++ /dev/null @@ -1,53 +0,0 @@ -/* File names on MS-DOS/Windows systems. - - Copyright (C) 2000-2001, 2004-2006, 2009-2020 Free Software - Foundation, Inc. - - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see <https://www.gnu.org/licenses/>. - - From Paul Eggert and Jim Meyering. */ - -#ifndef _DOSNAME_H -#define _DOSNAME_H - -#if (defined _WIN32 || defined __CYGWIN__ \ - || defined __EMX__ || defined __MSDOS__ || defined __DJGPP__) - /* This internal macro assumes ASCII, but all hosts that support drive - letters use ASCII. */ -# define _IS_DRIVE_LETTER(C) (((unsigned int) (C) | ('a' - 'A')) - 'a' \ - <= 'z' - 'a') -# define FILE_SYSTEM_PREFIX_LEN(Filename) \ - (_IS_DRIVE_LETTER ((Filename)[0]) && (Filename)[1] == ':' ? 2 : 0) -# ifndef __CYGWIN__ -# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 1 -# endif -# define ISSLASH(C) ((C) == '/' || (C) == '\\') -#else -# define FILE_SYSTEM_PREFIX_LEN(Filename) 0 -# define ISSLASH(C) ((C) == '/') -#endif - -#ifndef FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE -# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 -#endif - -#if FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE -# define IS_ABSOLUTE_FILE_NAME(F) ISSLASH ((F)[FILE_SYSTEM_PREFIX_LEN (F)]) -# else -# define IS_ABSOLUTE_FILE_NAME(F) \ - (ISSLASH ((F)[0]) || FILE_SYSTEM_PREFIX_LEN (F) != 0) -#endif -#define IS_RELATIVE_FILE_NAME(F) (! IS_ABSOLUTE_FILE_NAME (F)) - -#endif /* DOSNAME_H_ */ diff --git a/lib/dup2.c b/lib/dup2.c index b5c3a00c740..9bc3951f3d2 100644 --- a/lib/dup2.c +++ b/lib/dup2.c @@ -1,7 +1,6 @@ /* Duplicate an open file descriptor to a specified file descriptor. - Copyright (C) 1999, 2004-2007, 2009-2020 Free Software Foundation, - Inc. + Copyright (C) 1999, 2004-2007, 2009-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -26,28 +25,26 @@ #include <errno.h> #include <fcntl.h> -#if HAVE_DUP2 +#undef dup2 -# undef dup2 - -# if defined _WIN32 && ! defined __CYGWIN__ +#if defined _WIN32 && ! defined __CYGWIN__ /* Get declarations of the native Windows API functions. */ -# define WIN32_LEAN_AND_MEAN -# include <windows.h> +# define WIN32_LEAN_AND_MEAN +# include <windows.h> -# if HAVE_MSVC_INVALID_PARAMETER_HANDLER -# include "msvc-inval.h" -# endif +# if HAVE_MSVC_INVALID_PARAMETER_HANDLER +# include "msvc-inval.h" +# endif /* Get _get_osfhandle. */ -# if GNULIB_MSVC_NOTHROW -# include "msvc-nothrow.h" -# else -# include <io.h> -# endif +# if GNULIB_MSVC_NOTHROW +# include "msvc-nothrow.h" +# else +# include <io.h> +# endif -# if HAVE_MSVC_INVALID_PARAMETER_HANDLER +# if HAVE_MSVC_INVALID_PARAMETER_HANDLER static int dup2_nothrow (int fd, int desired_fd) { @@ -66,9 +63,9 @@ dup2_nothrow (int fd, int desired_fd) return result; } -# else -# define dup2_nothrow dup2 -# endif +# else +# define dup2_nothrow dup2 +# endif static int ms_windows_dup2 (int fd, int desired_fd) @@ -104,11 +101,11 @@ ms_windows_dup2 (int fd, int desired_fd) return result; } -# define dup2 ms_windows_dup2 +# define dup2 ms_windows_dup2 -# elif defined __KLIBC__ +#elif defined __KLIBC__ -# include <InnoTekLIBC/backend.h> +# include <InnoTekLIBC/backend.h> static int klibc_dup2dirfd (int fd, int desired_fd) @@ -156,81 +153,37 @@ klibc_dup2 (int fd, int desired_fd) return dupfd; } -# define dup2 klibc_dup2 -# endif +# define dup2 klibc_dup2 +#endif int rpl_dup2 (int fd, int desired_fd) { int result; -# ifdef F_GETFL +#ifdef F_GETFL /* On Linux kernels 2.6.26-2.6.29, dup2 (fd, fd) returns -EBADF. On Cygwin 1.5.x, dup2 (1, 1) returns 0. On Cygwin 1.7.17, dup2 (1, -1) dumps core. On Cygwin 1.7.25, dup2 (1, 256) can dump core. On Haiku, dup2 (fd, fd) mistakenly clears FD_CLOEXEC. */ -# if HAVE_SETDTABLESIZE +# if HAVE_SETDTABLESIZE setdtablesize (desired_fd + 1); -# endif +# endif if (desired_fd < 0) fd = desired_fd; if (fd == desired_fd) return fcntl (fd, F_GETFL) == -1 ? -1 : fd; -# endif +#endif result = dup2 (fd, desired_fd); /* Correct an errno value on FreeBSD 6.1 and Cygwin 1.5.x. */ if (result == -1 && errno == EMFILE) errno = EBADF; -# if REPLACE_FCHDIR +#if REPLACE_FCHDIR if (fd != desired_fd && result != -1) result = _gl_register_dup (fd, result); -# endif - return result; -} - -#else /* !HAVE_DUP2 */ - -/* On older platforms, dup2 did not exist. */ - -# ifndef F_DUPFD -static int -dupfd (int fd, int desired_fd) -{ - int duplicated_fd = dup (fd); - if (duplicated_fd < 0 || duplicated_fd == desired_fd) - return duplicated_fd; - else - { - int r = dupfd (fd, desired_fd); - int e = errno; - close (duplicated_fd); - errno = e; - return r; - } -} -# endif - -int -dup2 (int fd, int desired_fd) -{ - int result = fcntl (fd, F_GETFL) < 0 ? -1 : fd; - if (result == -1 || fd == desired_fd) - return result; - close (desired_fd); -# ifdef F_DUPFD - result = fcntl (fd, F_DUPFD, desired_fd); -# if REPLACE_FCHDIR - if (0 <= result) - result = _gl_register_dup (fd, result); -# endif -# else - result = dupfd (fd, desired_fd); -# endif - if (result == -1 && (errno == EMFILE || errno == EINVAL)) - errno = EBADF; +#endif return result; } -#endif /* !HAVE_DUP2 */ diff --git a/lib/explicit_bzero.c b/lib/explicit_bzero.c index c82771fb1e3..b1f5acb7771 100644 --- a/lib/explicit_bzero.c +++ b/lib/explicit_bzero.c @@ -25,8 +25,18 @@ # include <config.h> #endif +/* memset_s need this define */ +#if HAVE_MEMSET_S +# define __STDC_WANT_LIB_EXT1__ 1 +#endif + #include <string.h> +#if defined _WIN32 && !defined __CYGWIN__ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> +#endif + #if _LIBC /* glibc-internal users use __explicit_bzero_chk, and explicit_bzero redirects to that. */ @@ -38,8 +48,12 @@ void explicit_bzero (void *s, size_t len) { -#ifdef HAVE_EXPLICIT_MEMSET - explicit_memset (s, 0, len); +#if defined _WIN32 && !defined __CYGWIN__ + (void) SecureZeroMemory (s, len); +#elif HAVE_EXPLICIT_MEMSET + explicit_memset (s, '\0', len); +#elif HAVE_MEMSET_S + (void) memset_s (s, len, '\0', len); #else memset (s, '\0', len); # if defined __GNUC__ && !defined __clang__ diff --git a/lib/fchmodat.c b/lib/fchmodat.c new file mode 100644 index 00000000000..8950168608f --- /dev/null +++ b/lib/fchmodat.c @@ -0,0 +1,144 @@ +/* Change the protections of file relative to an open directory. + Copyright (C) 2006, 2009-2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* written by Jim Meyering and Paul Eggert */ + +/* If the user's config.h happens to include <sys/stat.h>, let it include only + the system's <sys/stat.h> here, so that orig_fchmodat doesn't recurse to + rpl_fchmodat. */ +#define __need_system_sys_stat_h +#include <config.h> + +/* Specification. */ +#include <sys/stat.h> +#undef __need_system_sys_stat_h + +#if HAVE_FCHMODAT +static int +orig_fchmodat (int dir, char const *file, mode_t mode, int flags) +{ + return fchmodat (dir, file, mode, flags); +} +#endif + +#include <errno.h> +#include <fcntl.h> +#include <stdio.h> +#include <stdlib.h> +#include <unistd.h> + +#ifdef __osf__ +/* Write "sys/stat.h" here, not <sys/stat.h>, otherwise OSF/1 5.1 DTK cc + eliminates this include because of the preliminary #include <sys/stat.h> + above. */ +# include "sys/stat.h" +#else +# include <sys/stat.h> +#endif + +#include <intprops.h> + +/* Invoke chmod or lchmod on FILE, using mode MODE, in the directory + open on descriptor FD. If possible, do it without changing the + working directory. Otherwise, resort to using save_cwd/fchdir, + then (chmod|lchmod)/restore_cwd. If either the save_cwd or the + restore_cwd fails, then give a diagnostic and exit nonzero. + Note that an attempt to use a FLAG value of AT_SYMLINK_NOFOLLOW + on a system without lchmod support causes this function to fail. */ + +#if HAVE_FCHMODAT +int +fchmodat (int dir, char const *file, mode_t mode, int flags) +{ +# if NEED_FCHMODAT_NONSYMLINK_FIX + if (flags == AT_SYMLINK_NOFOLLOW) + { + struct stat st; + +# if defined O_PATH && defined AT_EMPTY_PATH + /* Open a file descriptor with O_NOFOLLOW, to make sure we don't + follow symbolic links, if /proc is mounted. O_PATH is used to + avoid a failure if the file is not readable. + Cf. <https://sourceware.org/bugzilla/show_bug.cgi?id=14578> */ + int fd = openat (dir, file, O_PATH | O_NOFOLLOW | O_CLOEXEC); + if (fd < 0) + return fd; + + /* Up to Linux 5.3 at least, when FILE refers to a symbolic link, the + chmod call below will change the permissions of the symbolic link + - which is undesired - and on many file systems (ext4, btrfs, jfs, + xfs, ..., but not reiserfs) fail with error EOPNOTSUPP - which is + misleading. Therefore test for a symbolic link explicitly. + Use fstatat because fstat does not work on O_PATH descriptors + before Linux 3.6. */ + if (fstatat (fd, "", &st, AT_EMPTY_PATH) != 0) + { + int stat_errno = errno; + close (fd); + errno = stat_errno; + return -1; + } + if (S_ISLNK (st.st_mode)) + { + close (fd); + errno = EOPNOTSUPP; + return -1; + } + +# if defined __linux__ || defined __ANDROID__ + static char const fmt[] = "/proc/self/fd/%d"; + char buf[sizeof fmt - sizeof "%d" + INT_BUFSIZE_BOUND (int)]; + sprintf (buf, fmt, fd); + int chmod_result = chmod (buf, mode); + int chmod_errno = errno; + close (fd); + if (chmod_result == 0) + return chmod_result; + if (chmod_errno != ENOENT) + { + errno = chmod_errno; + return chmod_result; + } +# endif + /* /proc is not mounted or would not work as in GNU/Linux. */ + +# else + int fstatat_result = fstatat (dir, file, &st, AT_SYMLINK_NOFOLLOW); + if (fstatat_result != 0) + return fstatat_result; + if (S_ISLNK (st.st_mode)) + { + errno = EOPNOTSUPP; + return -1; + } +# endif + + /* Fall back on orig_fchmodat with no flags, despite a possible race. */ + flags = 0; + } +# endif + + return orig_fchmodat (dir, file, mode, flags); +} +#else +# define AT_FUNC_NAME fchmodat +# define AT_FUNC_F1 lchmod +# define AT_FUNC_F2 chmod +# define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW +# define AT_FUNC_POST_FILE_PARAM_DECLS , mode_t mode, int flag +# define AT_FUNC_POST_FILE_ARGS , mode +# include "at-func.c" +#endif diff --git a/lib/fcntl.in.h b/lib/fcntl.in.h index b2e1e5130d9..0a21c957baf 100644 --- a/lib/fcntl.in.h +++ b/lib/fcntl.in.h @@ -116,9 +116,15 @@ _GL_WARN_ON_USE (creat, "creat is not always POSIX compliant - " # endif _GL_FUNCDECL_RPL (fcntl, int, (int fd, int action, ...)); _GL_CXXALIAS_RPL (fcntl, int, (int fd, int action, ...)); +# if !GNULIB_defined_rpl_fcntl +# define GNULIB_defined_rpl_fcntl 1 +# endif # else # if !@HAVE_FCNTL@ _GL_FUNCDECL_SYS (fcntl, int, (int fd, int action, ...)); +# if !GNULIB_defined_fcntl +# define GNULIB_defined_fcntl 1 +# endif # endif _GL_CXXALIAS_SYS (fcntl, int, (int fd, int action, ...)); # endif diff --git a/lib/filemode.h b/lib/filemode.h index 8b8464f220a..f84a491625c 100644 --- a/lib/filemode.h +++ b/lib/filemode.h @@ -1,7 +1,7 @@ /* Make a string describing file modes. - Copyright (C) 1998-1999, 2003, 2006, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 1998-1999, 2003, 2006, 2009-2020 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/filename.h b/lib/filename.h new file mode 100644 index 00000000000..4598fb1d638 --- /dev/null +++ b/lib/filename.h @@ -0,0 +1,110 @@ +/* Basic filename support macros. + Copyright (C) 2001-2004, 2007-2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* From Paul Eggert and Jim Meyering. */ + +#ifndef _FILENAME_H +#define _FILENAME_H + +#include <string.h> + +#ifdef __cplusplus +extern "C" { +#endif + + +/* Filename support. + ISSLASH(C) tests whether C is a directory separator + character. + HAS_DEVICE(Filename) tests whether Filename contains a device + specification. + FILE_SYSTEM_PREFIX_LEN(Filename) length of the device specification + at the beginning of Filename, + index of the part consisting of + alternating components and slashes. + FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE + 1 when a non-empty device specification + can be followed by an empty or relative + part, + 0 when a non-empty device specification + must be followed by a slash, + 0 when device specification don't exist. + IS_ABSOLUTE_FILE_NAME(Filename) + tests whether Filename is independent of + any notion of "current directory". + IS_RELATIVE_FILE_NAME(Filename) + tests whether Filename may be concatenated + to a directory filename. + Note: On native Windows, OS/2, DOS, "c:" is neither an absolute nor a + relative file name! + IS_FILE_NAME_WITH_DIR(Filename) tests whether Filename contains a device + or directory specification. + */ +#if defined _WIN32 || defined __CYGWIN__ \ + || defined __EMX__ || defined __MSDOS__ || defined __DJGPP__ + /* Native Windows, Cygwin, OS/2, DOS */ +# define ISSLASH(C) ((C) == '/' || (C) == '\\') + /* Internal macro: Tests whether a character is a drive letter. */ +# define _IS_DRIVE_LETTER(C) \ + (((C) >= 'A' && (C) <= 'Z') || ((C) >= 'a' && (C) <= 'z')) + /* Help the compiler optimizing it. This assumes ASCII. */ +# undef _IS_DRIVE_LETTER +# define _IS_DRIVE_LETTER(C) \ + (((unsigned int) (C) | ('a' - 'A')) - 'a' <= 'z' - 'a') +# define HAS_DEVICE(Filename) \ + (_IS_DRIVE_LETTER ((Filename)[0]) && (Filename)[1] == ':') +# define FILE_SYSTEM_PREFIX_LEN(Filename) (HAS_DEVICE (Filename) ? 2 : 0) +# ifdef __CYGWIN__ +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 +# else + /* On native Windows, OS/2, DOS, the system has the notion of a + "current directory" on each drive. */ +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 1 +# endif +# if FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE +# define IS_ABSOLUTE_FILE_NAME(Filename) \ + ISSLASH ((Filename)[FILE_SYSTEM_PREFIX_LEN (Filename)]) +# else +# define IS_ABSOLUTE_FILE_NAME(Filename) \ + (ISSLASH ((Filename)[0]) || HAS_DEVICE (Filename)) +# endif +# define IS_RELATIVE_FILE_NAME(Filename) \ + (! (ISSLASH ((Filename)[0]) || HAS_DEVICE (Filename))) +# define IS_FILE_NAME_WITH_DIR(Filename) \ + (strchr ((Filename), '/') != NULL || strchr ((Filename), '\\') != NULL \ + || HAS_DEVICE (Filename)) +#else + /* Unix */ +# define ISSLASH(C) ((C) == '/') +# define HAS_DEVICE(Filename) ((void) (Filename), 0) +# define FILE_SYSTEM_PREFIX_LEN(Filename) ((void) (Filename), 0) +# define FILE_SYSTEM_DRIVE_PREFIX_CAN_BE_RELATIVE 0 +# define IS_ABSOLUTE_FILE_NAME(Filename) ISSLASH ((Filename)[0]) +# define IS_RELATIVE_FILE_NAME(Filename) (! ISSLASH ((Filename)[0])) +# define IS_FILE_NAME_WITH_DIR(Filename) (strchr ((Filename), '/') != NULL) +#endif + +/* Deprecated macros. For backward compatibility with old users of the + 'filename' module. */ +#define IS_ABSOLUTE_PATH IS_ABSOLUTE_FILE_NAME +#define IS_PATH_WITH_DIR IS_FILE_NAME_WITH_DIR + + +#ifdef __cplusplus +} +#endif + +#endif /* _FILENAME_H */ diff --git a/lib/fpending.c b/lib/fpending.c index 4db32eafd6a..802ebcba654 100644 --- a/lib/fpending.c +++ b/lib/fpending.c @@ -1,6 +1,6 @@ /* fpending.c -- return the number of pending output bytes on a stream - Copyright (C) 2000, 2004, 2006-2007, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2000, 2004, 2006-2007, 2009-2020 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fpending.h b/lib/fpending.h index 52639379975..a8b8859726d 100644 --- a/lib/fpending.h +++ b/lib/fpending.h @@ -1,7 +1,7 @@ /* Declare __fpending. - Copyright (C) 2000, 2003, 2005-2006, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2000, 2003, 2005-2006, 2009-2020 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/fsusage.c b/lib/fsusage.c index c0ee4533f9a..81960152d41 100644 --- a/lib/fsusage.c +++ b/lib/fsusage.c @@ -1,7 +1,7 @@ /* fsusage.c -- return space usage of mounted file systems - Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2020 Free - Software Foundation, Inc. + Copyright (C) 1991-1992, 1996, 1998-1999, 2002-2006, 2009-2020 Free Software + Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/ftoastr.c b/lib/ftoastr.c index 7a7d4113c22..47a83152e3f 100644 --- a/lib/ftoastr.c +++ b/lib/ftoastr.c @@ -33,20 +33,28 @@ #include <stdio.h> #include <stdlib.h> +#ifdef C_LOCALE +# include "c-snprintf.h" +# include "c-strtod.h" +# define PREFIX(name) c_ ## name +#else +# define PREFIX(name) name +#endif + #if LENGTH == 3 # define FLOAT long double # define FLOAT_DIG LDBL_DIG # define FLOAT_MIN LDBL_MIN # define FLOAT_PREC_BOUND _GL_LDBL_PREC_BOUND -# define FTOASTR ldtoastr +# define FTOASTR PREFIX (ldtoastr) # define PROMOTED_FLOAT long double -# define STRTOF strtold +# define STRTOF PREFIX (strtold) #elif LENGTH == 2 # define FLOAT double # define FLOAT_DIG DBL_DIG # define FLOAT_MIN DBL_MIN # define FLOAT_PREC_BOUND _GL_DBL_PREC_BOUND -# define FTOASTR dtoastr +# define FTOASTR PREFIX (dtoastr) # define PROMOTED_FLOAT double #else # define LENGTH 1 @@ -54,7 +62,7 @@ # define FLOAT_DIG FLT_DIG # define FLOAT_MIN FLT_MIN # define FLOAT_PREC_BOUND _GL_FLT_PREC_BOUND -# define FTOASTR ftoastr +# define FTOASTR PREFIX (ftoastr) # define PROMOTED_FLOAT double # if HAVE_STRTOF # define STRTOF strtof @@ -65,13 +73,16 @@ may generate one or two extra digits, but that's better than not working at all. */ #ifndef STRTOF -# define STRTOF strtod +# define STRTOF PREFIX (strtod) #endif /* On hosts where it's not known that snprintf works, use sprintf to implement the subset needed here. Typically BUFSIZE is big enough and there's little or no performance hit. */ -#if ! GNULIB_SNPRINTF +#ifdef C_LOCALE +# undef snprintf +# define snprintf c_snprintf +#elif ! GNULIB_SNPRINTF # undef snprintf # define snprintf ftoastr_snprintf static int diff --git a/lib/ftoastr.h b/lib/ftoastr.h index d945cc064a7..78b569f3d97 100644 --- a/lib/ftoastr.h +++ b/lib/ftoastr.h @@ -18,6 +18,7 @@ /* Written by Paul Eggert. */ #ifndef _GL_FTOASTR_H +#define _GL_FTOASTR_H #include "intprops.h" #include <float.h> @@ -48,6 +49,12 @@ int ftoastr (char *buf, size_t bufsize, int flags, int width, float x); int dtoastr (char *buf, size_t bufsize, int flags, int width, double x); int ldtoastr (char *buf, size_t bufsize, int flags, int width, long double x); +/* The last two functions except that the formatting takes place in + the C locale. */ +int c_dtoastr (char *buf, size_t bufsize, int flags, int width, double x); +int c_ldtoastr (char *buf, size_t bufsize, int flags, int width, long double x); + + /* Flag values for ftoastr etc. These can be ORed together. */ enum { diff --git a/lib/futimens.c b/lib/futimens.c new file mode 100644 index 00000000000..83fb27cb6aa --- /dev/null +++ b/lib/futimens.c @@ -0,0 +1,37 @@ +/* Set the access and modification time of an open fd. + Copyright (C) 2009-2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* written by Eric Blake */ + +#include <config.h> + +#include <sys/stat.h> + +#include "utimens.h" + +/* Set the access and modification timestamps of FD to be + TIMESPEC[0] and TIMESPEC[1], respectively. + Fail with ENOSYS on systems without futimes (or equivalent). + If TIMESPEC is null, set the timestamps to the current time. + Return 0 on success, -1 (setting errno) on failure. */ +int +futimens (int fd, struct timespec const times[2]) +{ + /* fdutimens also works around bugs in native futimens, when running + with glibc compiled against newer headers but on a Linux kernel + older than 2.6.32. */ + return fdutimens (fd, NULL, times); +} diff --git a/lib/getgroups.c b/lib/getgroups.c index b1ec68dadf9..4396b4d64b7 100644 --- a/lib/getgroups.c +++ b/lib/getgroups.c @@ -1,7 +1,6 @@ /* provide consistent interface to getgroups for systems that don't allow N==0 - Copyright (C) 1996, 1999, 2003, 2006-2020 Free Software Foundation, - Inc. + Copyright (C) 1996, 1999, 2003, 2006-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/getloadavg.c b/lib/getloadavg.c index 507017339cc..468e2506709 100644 --- a/lib/getloadavg.c +++ b/lib/getloadavg.c @@ -1,7 +1,7 @@ /* Get the system load averages. - Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2020 Free - Software Foundation, Inc. + Copyright (C) 1985-1989, 1991-1995, 1997, 1999-2000, 2003-2020 Free Software + Foundation, Inc. NOTE: The canonical source of this file is maintained with gnulib. Bugs can be reported to bug-gnulib@gnu.org. @@ -512,7 +512,7 @@ getloadavg (double loadavg[], int nelem) char const *ptr = ldavgbuf; int fd, count, saved_errno; - fd = open (LINUX_LDAV_FILE, O_RDONLY); + fd = open (LINUX_LDAV_FILE, O_RDONLY | O_CLOEXEC); if (fd == -1) return -1; count = read (fd, ldavgbuf, sizeof ldavgbuf - 1); @@ -550,7 +550,7 @@ getloadavg (double loadavg[], int nelem) for (ptr++; '0' <= *ptr && *ptr <= '9'; ptr++) numerator = 10 * numerator + (*ptr - '0'), denominator *= 10; - loadavg[elem++] = numerator / denominator; + loadavg[elem] = numerator / denominator; } return elem; @@ -567,15 +567,22 @@ getloadavg (double loadavg[], int nelem) unsigned long int load_ave[3], scale; int count; - FILE *fp; - - fp = fopen (NETBSD_LDAV_FILE, "r"); - if (fp == NULL) - return -1; - count = fscanf (fp, "%lu %lu %lu %lu\n", + char readbuf[4 * INT_BUFSIZE_BOUND (unsigned long int) + 1]; + int fd = open (NETBSD_LDAV_FILE, O_RDONLY | O_CLOEXEC); + if (fd < 0) + return fd; + int nread = read (fd, readbuf, sizeof readbuf - 1); + int err = errno; + close (fd); + if (nread < 0) + { + errno = err; + return -1; + } + readbuf[nread] = '\0'; + count = sscanf (readbuf, "%lu %lu %lu %lu\n", &load_ave[0], &load_ave[1], &load_ave[2], &scale); - (void) fclose (fp); if (count != 4) { errno = ENOTSUP; @@ -869,27 +876,11 @@ getloadavg (double loadavg[], int nelem) if (!getloadavg_initialized) { # ifndef SUNOS_5 - /* Set the channel to close on exec, so it does not - litter any child's descriptor table. */ -# ifndef O_CLOEXEC -# define O_CLOEXEC 0 -# endif int fd = open ("/dev/kmem", O_RDONLY | O_CLOEXEC); if (0 <= fd) { -# if F_DUPFD_CLOEXEC - if (fd <= STDERR_FILENO) - { - int fd1 = fcntl (fd, F_DUPFD_CLOEXEC, STDERR_FILENO + 1); - close (fd); - fd = fd1; - } -# endif - if (0 <= fd) - { - channel = fd; - getloadavg_initialized = true; - } + channel = fd; + getloadavg_initialized = true; } # else /* SUNOS_5 */ /* We pass 0 for the kernel, corefile, and swapfile names diff --git a/lib/getopt-pfx-core.h b/lib/getopt-pfx-core.h index da0a6d0c3c4..ec545c1b51c 100644 --- a/lib/getopt-pfx-core.h +++ b/lib/getopt-pfx-core.h @@ -48,6 +48,14 @@ # define optind __GETOPT_ID (optind) # define optopt __GETOPT_ID (optopt) +/* Work around a a problem on macOS, which declares getopt with a + trailing __DARWIN_ALIAS(getopt) that would expand to something like + __asm("_" "rpl_getopt" "$UNIX2003") were it not for the following + hack to suppress the macOS declaration <https://bugs.gnu.org/40205>. */ +# ifdef __APPLE__ +# define _GETOPT +# endif + /* The system's getopt.h may have already included getopt-core.h to declare the unprefixed identifiers. Undef _GETOPT_CORE_H so that getopt-core.h declares them with prefixes. */ diff --git a/lib/getrandom.c b/lib/getrandom.c new file mode 100644 index 00000000000..f8695abf30a --- /dev/null +++ b/lib/getrandom.c @@ -0,0 +1,187 @@ +/* Obtain a series of random bytes. + + Copyright 2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* Written by Paul Eggert. */ + +#include <config.h> + +#include <sys/random.h> + +#include <errno.h> +#include <fcntl.h> +#include <stdbool.h> +#include <unistd.h> + +#if defined _WIN32 && ! defined __CYGWIN__ +# define WIN32_LEAN_AND_MEAN +# include <windows.h> +# if HAVE_BCRYPT_H +# include <bcrypt.h> +# else +# define NTSTATUS LONG +typedef void * BCRYPT_ALG_HANDLE; +# define BCRYPT_USE_SYSTEM_PREFERRED_RNG 0x00000002 +# if HAVE_LIB_BCRYPT +extern NTSTATUS WINAPI BCryptGenRandom (BCRYPT_ALG_HANDLE, UCHAR *, ULONG, ULONG); +# endif +# endif +# if !HAVE_LIB_BCRYPT +# include <wincrypt.h> +# ifndef CRYPT_VERIFY_CONTEXT +# define CRYPT_VERIFY_CONTEXT 0xF0000000 +# endif +# endif +#endif + +#include "minmax.h" + +#if defined _WIN32 && ! defined __CYGWIN__ + +/* Don't assume that UNICODE is not defined. */ +# undef LoadLibrary +# define LoadLibrary LoadLibraryA +# undef CryptAcquireContext +# define CryptAcquireContext CryptAcquireContextA + +# if !HAVE_LIB_BCRYPT + +/* Avoid warnings from gcc -Wcast-function-type. */ +# define GetProcAddress \ + (void *) GetProcAddress + +/* BCryptGenRandom with the BCRYPT_USE_SYSTEM_PREFERRED_RNG flag works only + starting with Windows 7. */ +typedef NTSTATUS (WINAPI * BCryptGenRandomFuncType) (BCRYPT_ALG_HANDLE, UCHAR *, ULONG, ULONG); +static BCryptGenRandomFuncType BCryptGenRandomFunc = NULL; +static BOOL initialized = FALSE; + +static void +initialize (void) +{ + HMODULE bcrypt = LoadLibrary ("bcrypt.dll"); + if (bcrypt != NULL) + { + BCryptGenRandomFunc = + (BCryptGenRandomFuncType) GetProcAddress (bcrypt, "BCryptGenRandom"); + } + initialized = TRUE; +} + +# else + +# define BCryptGenRandomFunc BCryptGenRandom + +# endif + +#else +/* These devices exist on all platforms except native Windows. */ + +/* Name of a device through which the kernel returns high quality random + numbers, from an entropy pool. When the pool is empty, the call blocks + until entropy sources have added enough bits of entropy. */ +# ifndef NAME_OF_RANDOM_DEVICE +# define NAME_OF_RANDOM_DEVICE "/dev/random" +# endif + +/* Name of a device through which the kernel returns random or pseudo-random + numbers. It uses an entropy pool, but, in order to avoid blocking, adds + bits generated by a pseudo-random number generator, as needed. */ +# ifndef NAME_OF_NONCE_DEVICE +# define NAME_OF_NONCE_DEVICE "/dev/urandom" +# endif + +#endif + +/* Set BUFFER (of size LENGTH) to random bytes under the control of FLAGS. + Return the number of bytes written (> 0). + Upon error, return -1 and set errno. */ +ssize_t +getrandom (void *buffer, size_t length, unsigned int flags) +#undef getrandom +{ +#if defined _WIN32 && ! defined __CYGWIN__ + /* BCryptGenRandom, defined in <bcrypt.h> + <https://docs.microsoft.com/en-us/windows/win32/api/bcrypt/nf-bcrypt-bcryptgenrandom> + with the BCRYPT_USE_SYSTEM_PREFERRED_RNG flag + works in Windows 7 and newer. */ + static int bcrypt_not_working /* = 0 */; + if (!bcrypt_not_working) + { +# if !HAVE_LIB_BCRYPT + if (!initialized) + initialize (); +# endif + if (BCryptGenRandomFunc != NULL + && BCryptGenRandomFunc (NULL, buffer, length, + BCRYPT_USE_SYSTEM_PREFERRED_RNG) + == 0 /*STATUS_SUCCESS*/) + return length; + bcrypt_not_working = 1; + } +# if !HAVE_LIB_BCRYPT + /* CryptGenRandom, defined in <wincrypt.h> + <https://docs.microsoft.com/en-us/windows/win32/api/wincrypt/nf-wincrypt-cryptgenrandom> + works in older releases as well, but is now deprecated. + CryptAcquireContext, defined in <wincrypt.h> + <https://docs.microsoft.com/en-us/windows/win32/api/wincrypt/nf-wincrypt-cryptacquirecontexta> */ + { + static int crypt_initialized /* = 0 */; + static HCRYPTPROV provider; + if (!crypt_initialized) + { + if (CryptAcquireContext (&provider, NULL, NULL, PROV_RSA_FULL, + CRYPT_VERIFY_CONTEXT)) + crypt_initialized = 1; + else + crypt_initialized = -1; + } + if (crypt_initialized >= 0) + { + if (!CryptGenRandom (provider, length, buffer)) + { + errno = EIO; + return -1; + } + return length; + } + } +# endif + errno = ENOSYS; + return -1; +#elif HAVE_GETRANDOM + return getrandom (buffer, length, flags); +#else + static int randfd[2] = { -1, -1 }; + bool devrandom = (flags & GRND_RANDOM) != 0; + int fd = randfd[devrandom]; + + if (fd < 0) + { + static char const randdevice[][MAX (sizeof NAME_OF_NONCE_DEVICE, + sizeof NAME_OF_RANDOM_DEVICE)] + = { NAME_OF_NONCE_DEVICE, NAME_OF_RANDOM_DEVICE }; + int oflags = (O_RDONLY + O_CLOEXEC + + (flags & GRND_NONBLOCK ? O_NONBLOCK : 0)); + fd = open (randdevice[devrandom], oflags); + if (fd < 0) + return fd; + randfd[devrandom] = fd; + } + + return read (fd, buffer, length); +#endif +} diff --git a/lib/gettext.h b/lib/gettext.h index 4c6b5efcc3f..0bd1e13348a 100644 --- a/lib/gettext.h +++ b/lib/gettext.h @@ -1,6 +1,6 @@ /* Convenience header for conditional use of GNU <libintl.h>. - Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2020 Free - Software Foundation, Inc. + Copyright (C) 1995-1998, 2000-2002, 2004-2006, 2009-2020 Free Software + Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/gettime.c b/lib/gettime.c index f212a238a88..f5b8ca53b5f 100644 --- a/lib/gettime.c +++ b/lib/gettime.c @@ -1,7 +1,6 @@ /* gettime -- get the system clock - Copyright (C) 2002, 2004-2007, 2009-2020 Free Software Foundation, - Inc. + Copyright (C) 2002, 2004-2007, 2009-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/gettimeofday.c b/lib/gettimeofday.c index b5e2c300305..057cebdb163 100644 --- a/lib/gettimeofday.c +++ b/lib/gettimeofday.c @@ -1,7 +1,6 @@ /* Provide gettimeofday for systems that don't have it or for which it's broken. - Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -34,9 +33,15 @@ #ifdef WINDOWS_NATIVE +/* Don't assume that UNICODE is not defined. */ +# undef LoadLibrary +# define LoadLibrary LoadLibraryA + +# if !(_WIN32_WINNT >= _WIN32_WINNT_WIN8) + /* Avoid warnings from gcc -Wcast-function-type. */ -# define GetProcAddress \ - (void *) GetProcAddress +# define GetProcAddress \ + (void *) GetProcAddress /* GetSystemTimePreciseAsFileTime was introduced only in Windows 8. */ typedef void (WINAPI * GetSystemTimePreciseAsFileTimeFuncType) (FILETIME *lpTime); @@ -55,6 +60,12 @@ initialize (void) initialized = TRUE; } +# else + +# define GetSystemTimePreciseAsFileTimeFunc GetSystemTimePreciseAsFileTime + +# endif + #endif /* This is a wrapper for gettimeofday. It is used only on systems @@ -85,8 +96,10 @@ gettimeofday (struct timeval *restrict tv, void *restrict tz) <http://www.windowstimestamp.com/description>. */ FILETIME current_time; +# if !(_WIN32_WINNT >= _WIN32_WINNT_WIN8) if (!initialized) initialize (); +# endif if (GetSystemTimePreciseAsFileTimeFunc != NULL) GetSystemTimePreciseAsFileTimeFunc (¤t_time); else diff --git a/lib/gnulib.mk.in b/lib/gnulib.mk.in index 5adea10c18e..68cae8faf74 100644 --- a/lib/gnulib.mk.in +++ b/lib/gnulib.mk.in @@ -86,7 +86,6 @@ # crypto/sha512-buffer \ # d-type \ # diffseq \ -# dosname \ # double-slash-root \ # dtoastr \ # dtotimespec \ @@ -95,18 +94,22 @@ # execinfo \ # explicit_bzero \ # faccessat \ +# fchmodat \ # fcntl \ # fcntl-h \ # fdopendir \ # filemode \ +# filename \ # filevercmp \ # flexmember \ # fpieee \ # fstatat \ # fsusage \ # fsync \ +# futimens \ # getloadavg \ # getopt-gnu \ +# getrandom \ # gettime \ # gettimeofday \ # gitlog-to-changelog \ @@ -114,6 +117,7 @@ # ignore-value \ # intprops \ # largefile \ +# libgmp \ # lstat \ # manywarnings \ # memmem-simple \ @@ -127,7 +131,6 @@ # pipe2 \ # pselect \ # pthread_sigmask \ -# putenv \ # qcopy-acl \ # readlink \ # readlinkat \ @@ -155,7 +158,7 @@ # timespec-sub \ # unlocked-io \ # update-copyright \ -# utimens \ +# utimensat \ # vla \ # warnings @@ -243,14 +246,14 @@ GL_GENERATE_ALLOCA_H = @GL_GENERATE_ALLOCA_H@ GL_GENERATE_BYTESWAP_H = @GL_GENERATE_BYTESWAP_H@ GL_GENERATE_ERRNO_H = @GL_GENERATE_ERRNO_H@ GL_GENERATE_EXECINFO_H = @GL_GENERATE_EXECINFO_H@ +GL_GENERATE_GMP_H = @GL_GENERATE_GMP_H@ GL_GENERATE_IEEE754_H = @GL_GENERATE_IEEE754_H@ GL_GENERATE_LIMITS_H = @GL_GENERATE_LIMITS_H@ GL_GENERATE_STDALIGN_H = @GL_GENERATE_STDALIGN_H@ GL_GENERATE_STDDEF_H = @GL_GENERATE_STDDEF_H@ GL_GENERATE_STDINT_H = @GL_GENERATE_STDINT_H@ GMALLOC_OBJ = @GMALLOC_OBJ@ -GMP_LIB = @GMP_LIB@ -GMP_OBJ = @GMP_OBJ@ +GMP_H = @GMP_H@ GNULIB_ACCESS = @GNULIB_ACCESS@ GNULIB_ALPHASORT = @GNULIB_ALPHASORT@ GNULIB_ATOLL = @GNULIB_ATOLL@ @@ -310,16 +313,20 @@ GNULIB_GETCWD = @GNULIB_GETCWD@ GNULIB_GETDELIM = @GNULIB_GETDELIM@ GNULIB_GETDOMAINNAME = @GNULIB_GETDOMAINNAME@ GNULIB_GETDTABLESIZE = @GNULIB_GETDTABLESIZE@ +GNULIB_GETENTROPY = @GNULIB_GETENTROPY@ GNULIB_GETGROUPS = @GNULIB_GETGROUPS@ GNULIB_GETHOSTNAME = @GNULIB_GETHOSTNAME@ GNULIB_GETLINE = @GNULIB_GETLINE@ GNULIB_GETLOADAVG = @GNULIB_GETLOADAVG@ GNULIB_GETLOGIN = @GNULIB_GETLOGIN@ GNULIB_GETLOGIN_R = @GNULIB_GETLOGIN_R@ +GNULIB_GETOPT_POSIX = @GNULIB_GETOPT_POSIX@ GNULIB_GETPAGESIZE = @GNULIB_GETPAGESIZE@ GNULIB_GETPASS = @GNULIB_GETPASS@ +GNULIB_GETRANDOM = @GNULIB_GETRANDOM@ GNULIB_GETSUBOPT = @GNULIB_GETSUBOPT@ GNULIB_GETTIMEOFDAY = @GNULIB_GETTIMEOFDAY@ +GNULIB_GETUMASK = @GNULIB_GETUMASK@ GNULIB_GETUSERSHELL = @GNULIB_GETUSERSHELL@ GNULIB_GL_UNISTD_H_GETOPT = @GNULIB_GL_UNISTD_H_GETOPT@ GNULIB_GRANTPT = @GNULIB_GRANTPT@ @@ -543,7 +550,6 @@ HAVE_DECL_UNSETENV = @HAVE_DECL_UNSETENV@ HAVE_DECL_VSNPRINTF = @HAVE_DECL_VSNPRINTF@ HAVE_DIRENT_H = @HAVE_DIRENT_H@ HAVE_DPRINTF = @HAVE_DPRINTF@ -HAVE_DUP2 = @HAVE_DUP2@ HAVE_DUP3 = @HAVE_DUP3@ HAVE_EUIDACCESS = @HAVE_EUIDACCESS@ HAVE_EXPLICIT_BZERO = @HAVE_EXPLICIT_BZERO@ @@ -563,14 +569,17 @@ HAVE_FTELLO = @HAVE_FTELLO@ HAVE_FTRUNCATE = @HAVE_FTRUNCATE@ HAVE_FUTIMENS = @HAVE_FUTIMENS@ HAVE_GETDTABLESIZE = @HAVE_GETDTABLESIZE@ +HAVE_GETENTROPY = @HAVE_GETENTROPY@ HAVE_GETGROUPS = @HAVE_GETGROUPS@ HAVE_GETHOSTNAME = @HAVE_GETHOSTNAME@ HAVE_GETLOGIN = @HAVE_GETLOGIN@ HAVE_GETOPT_H = @HAVE_GETOPT_H@ HAVE_GETPAGESIZE = @HAVE_GETPAGESIZE@ HAVE_GETPASS = @HAVE_GETPASS@ +HAVE_GETRANDOM = @HAVE_GETRANDOM@ HAVE_GETSUBOPT = @HAVE_GETSUBOPT@ HAVE_GETTIMEOFDAY = @HAVE_GETTIMEOFDAY@ +HAVE_GETUMASK = @HAVE_GETUMASK@ HAVE_GRANTPT = @HAVE_GRANTPT@ HAVE_GROUP_MEMBER = @HAVE_GROUP_MEMBER@ HAVE_IMAXDIV_T = @HAVE_IMAXDIV_T@ @@ -580,13 +589,11 @@ HAVE_LCHMOD = @HAVE_LCHMOD@ HAVE_LCHOWN = @HAVE_LCHOWN@ HAVE_LINK = @HAVE_LINK@ HAVE_LINKAT = @HAVE_LINKAT@ -HAVE_LONG_LONG_INT = @HAVE_LONG_LONG_INT@ HAVE_LSTAT = @HAVE_LSTAT@ HAVE_MAKEINFO = @HAVE_MAKEINFO@ HAVE_MAX_ALIGN_T = @HAVE_MAX_ALIGN_T@ HAVE_MBSLEN = @HAVE_MBSLEN@ HAVE_MBTOWC = @HAVE_MBTOWC@ -HAVE_MEMCHR = @HAVE_MEMCHR@ HAVE_MEMPCPY = @HAVE_MEMPCPY@ HAVE_MKDIRAT = @HAVE_MKDIRAT@ HAVE_MKDTEMP = @HAVE_MKDTEMP@ @@ -666,6 +673,7 @@ HAVE_SYS_CDEFS_H = @HAVE_SYS_CDEFS_H@ HAVE_SYS_INTTYPES_H = @HAVE_SYS_INTTYPES_H@ HAVE_SYS_LOADAVG_H = @HAVE_SYS_LOADAVG_H@ HAVE_SYS_PARAM_H = @HAVE_SYS_PARAM_H@ +HAVE_SYS_RANDOM_H = @HAVE_SYS_RANDOM_H@ HAVE_SYS_SELECT_H = @HAVE_SYS_SELECT_H@ HAVE_SYS_TIME_H = @HAVE_SYS_TIME_H@ HAVE_SYS_TYPES_H = @HAVE_SYS_TYPES_H@ @@ -676,7 +684,6 @@ HAVE_TZSET = @HAVE_TZSET@ HAVE_UNISTD_H = @HAVE_UNISTD_H@ HAVE_UNLINKAT = @HAVE_UNLINKAT@ HAVE_UNLOCKPT = @HAVE_UNLOCKPT@ -HAVE_UNSIGNED_LONG_LONG_INT = @HAVE_UNSIGNED_LONG_LONG_INT@ HAVE_USLEEP = @HAVE_USLEEP@ HAVE_UTIMENSAT = @HAVE_UTIMENSAT@ HAVE_VASPRINTF = @HAVE_VASPRINTF@ @@ -753,6 +760,8 @@ LIB_ACL = @LIB_ACL@ LIB_CLOCK_GETTIME = @LIB_CLOCK_GETTIME@ LIB_EACCESS = @LIB_EACCESS@ LIB_EXECINFO = @LIB_EXECINFO@ +LIB_GETRANDOM = @LIB_GETRANDOM@ +LIB_GMP = @LIB_GMP@ LIB_MATH = @LIB_MATH@ LIB_PTHREAD = @LIB_PTHREAD@ LIB_PTHREAD_SIGMASK = @LIB_PTHREAD_SIGMASK@ @@ -768,6 +777,7 @@ MAKEINFO = @MAKEINFO@ MAKE_PROG = @MAKE_PROG@ MKDIR_P = @MKDIR_P@ MODULES_OBJ = @MODULES_OBJ@ +MODULES_SECONDARY_SUFFIX = @MODULES_SECONDARY_SUFFIX@ MODULES_SUFFIX = @MODULES_SUFFIX@ NEXT_AS_FIRST_DIRECTIVE_DIRENT_H = @NEXT_AS_FIRST_DIRECTIVE_DIRENT_H@ NEXT_AS_FIRST_DIRECTIVE_ERRNO_H = @NEXT_AS_FIRST_DIRECTIVE_ERRNO_H@ @@ -781,6 +791,7 @@ NEXT_AS_FIRST_DIRECTIVE_STDINT_H = @NEXT_AS_FIRST_DIRECTIVE_STDINT_H@ NEXT_AS_FIRST_DIRECTIVE_STDIO_H = @NEXT_AS_FIRST_DIRECTIVE_STDIO_H@ NEXT_AS_FIRST_DIRECTIVE_STDLIB_H = @NEXT_AS_FIRST_DIRECTIVE_STDLIB_H@ NEXT_AS_FIRST_DIRECTIVE_STRING_H = @NEXT_AS_FIRST_DIRECTIVE_STRING_H@ +NEXT_AS_FIRST_DIRECTIVE_SYS_RANDOM_H = @NEXT_AS_FIRST_DIRECTIVE_SYS_RANDOM_H@ NEXT_AS_FIRST_DIRECTIVE_SYS_SELECT_H = @NEXT_AS_FIRST_DIRECTIVE_SYS_SELECT_H@ NEXT_AS_FIRST_DIRECTIVE_SYS_STAT_H = @NEXT_AS_FIRST_DIRECTIVE_SYS_STAT_H@ NEXT_AS_FIRST_DIRECTIVE_SYS_TIME_H = @NEXT_AS_FIRST_DIRECTIVE_SYS_TIME_H@ @@ -799,6 +810,7 @@ NEXT_STDINT_H = @NEXT_STDINT_H@ NEXT_STDIO_H = @NEXT_STDIO_H@ NEXT_STDLIB_H = @NEXT_STDLIB_H@ NEXT_STRING_H = @NEXT_STRING_H@ +NEXT_SYS_RANDOM_H = @NEXT_SYS_RANDOM_H@ NEXT_SYS_SELECT_H = @NEXT_SYS_SELECT_H@ NEXT_SYS_STAT_H = @NEXT_SYS_STAT_H@ NEXT_SYS_TIME_H = @NEXT_SYS_TIME_H@ @@ -855,6 +867,7 @@ REPLACE_DPRINTF = @REPLACE_DPRINTF@ REPLACE_DUP = @REPLACE_DUP@ REPLACE_DUP2 = @REPLACE_DUP2@ REPLACE_FACCESSAT = @REPLACE_FACCESSAT@ +REPLACE_FCHMODAT = @REPLACE_FCHMODAT@ REPLACE_FCHOWNAT = @REPLACE_FCHOWNAT@ REPLACE_FCLOSE = @REPLACE_FCLOSE@ REPLACE_FCNTL = @REPLACE_FCNTL@ @@ -882,6 +895,7 @@ REPLACE_GETLINE = @REPLACE_GETLINE@ REPLACE_GETLOGIN_R = @REPLACE_GETLOGIN_R@ REPLACE_GETPAGESIZE = @REPLACE_GETPAGESIZE@ REPLACE_GETPASS = @REPLACE_GETPASS@ +REPLACE_GETRANDOM = @REPLACE_GETRANDOM@ REPLACE_GETTIMEOFDAY = @REPLACE_GETTIMEOFDAY@ REPLACE_GMTIME = @REPLACE_GMTIME@ REPLACE_INITSTATE = @REPLACE_INITSTATE@ @@ -1001,6 +1015,7 @@ UINT64_MAX_EQ_ULONG_MAX = @UINT64_MAX_EQ_ULONG_MAX@ UNDEFINE_STRTOK_R = @UNDEFINE_STRTOK_R@ UNEXEC_OBJ = @UNEXEC_OBJ@ UNISTD_H_DEFINES_STRUCT_TIMESPEC = @UNISTD_H_DEFINES_STRUCT_TIMESPEC@ +UNISTD_H_HAVE_SYS_RANDOM_H = @UNISTD_H_HAVE_SYS_RANDOM_H@ UNISTD_H_HAVE_WINSOCK2_H = @UNISTD_H_HAVE_WINSOCK2_H@ UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS = @UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS@ USE_ACL = @USE_ACL@ @@ -1070,7 +1085,6 @@ gamegroup = @gamegroup@ gameuser = @gameuser@ gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7 = @gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7@ gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9 = @gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9@ -gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467 = @gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467@ gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b = @gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b@ gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31 = @gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31@ gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c = @gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c@ @@ -1082,9 +1096,11 @@ gl_GNULIB_ENABLED_dirfd = @gl_GNULIB_ENABLED_dirfd@ gl_GNULIB_ENABLED_euidaccess = @gl_GNULIB_ENABLED_euidaccess@ gl_GNULIB_ENABLED_getdtablesize = @gl_GNULIB_ENABLED_getdtablesize@ gl_GNULIB_ENABLED_getgroups = @gl_GNULIB_ENABLED_getgroups@ +gl_GNULIB_ENABLED_lchmod = @gl_GNULIB_ENABLED_lchmod@ gl_GNULIB_ENABLED_malloca = @gl_GNULIB_ENABLED_malloca@ gl_GNULIB_ENABLED_open = @gl_GNULIB_ENABLED_open@ gl_GNULIB_ENABLED_strtoll = @gl_GNULIB_ENABLED_strtoll@ +gl_GNULIB_ENABLED_utimens = @gl_GNULIB_ENABLED_utimens@ gl_LIBOBJS = @gl_LIBOBJS@ gl_LTLIBOBJS = @gl_LTLIBOBJS@ gltests_LIBOBJS = @gltests_LIBOBJS@ @@ -1198,14 +1214,20 @@ endif ifeq (,$(OMIT_GNULIB_MODULE_at-internal)) ifneq (,$(gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b)) +libgnu_a_SOURCES += openat-priv.h openat-proc.c endif -EXTRA_DIST += openat-priv.h openat-proc.c +endif +## end gnulib module at-internal + +## begin gnulib module attribute +ifeq (,$(OMIT_GNULIB_MODULE_attribute)) -EXTRA_libgnu_a_SOURCES += openat-proc.c + +EXTRA_DIST += attribute.h endif -## end gnulib module at-internal +## end gnulib module attribute ## begin gnulib module binary-io ifeq (,$(OMIT_GNULIB_MODULE_binary-io)) @@ -1451,15 +1473,6 @@ EXTRA_libgnu_a_SOURCES += dirfd.c endif ## end gnulib module dirfd -## begin gnulib module dosname -ifeq (,$(OMIT_GNULIB_MODULE_dosname)) - - -EXTRA_DIST += dosname.h - -endif -## end gnulib module dosname - ## begin gnulib module dtoastr ifeq (,$(OMIT_GNULIB_MODULE_dtoastr)) @@ -1589,6 +1602,17 @@ EXTRA_libgnu_a_SOURCES += at-func.c faccessat.c endif ## end gnulib module faccessat +## begin gnulib module fchmodat +ifeq (,$(OMIT_GNULIB_MODULE_fchmodat)) + + +EXTRA_DIST += at-func.c fchmodat.c + +EXTRA_libgnu_a_SOURCES += at-func.c fchmodat.c + +endif +## end gnulib module fchmodat + ## begin gnulib module fcntl ifeq (,$(OMIT_GNULIB_MODULE_fcntl)) @@ -1660,6 +1684,15 @@ EXTRA_DIST += filemode.h endif ## end gnulib module filemode +## begin gnulib module filename +ifeq (,$(OMIT_GNULIB_MODULE_filename)) + + +EXTRA_DIST += filename.h + +endif +## end gnulib module filename + ## begin gnulib module filevercmp ifeq (,$(OMIT_GNULIB_MODULE_filevercmp)) @@ -1723,6 +1756,17 @@ EXTRA_libgnu_a_SOURCES += fsync.c endif ## end gnulib module fsync +## begin gnulib module futimens +ifeq (,$(OMIT_GNULIB_MODULE_futimens)) + + +EXTRA_DIST += futimens.c + +EXTRA_libgnu_a_SOURCES += futimens.c + +endif +## end gnulib module futimens + ## begin gnulib module getdtablesize ifeq (,$(OMIT_GNULIB_MODULE_getdtablesize)) @@ -1798,6 +1842,17 @@ EXTRA_libgnu_a_SOURCES += getopt.c getopt1.c endif ## end gnulib module getopt-posix +## begin gnulib module getrandom +ifeq (,$(OMIT_GNULIB_MODULE_getrandom)) + + +EXTRA_DIST += getrandom.c + +EXTRA_libgnu_a_SOURCES += getrandom.c + +endif +## end gnulib module getrandom + ## begin gnulib module gettext-h ifeq (,$(OMIT_GNULIB_MODULE_gettext-h)) @@ -1910,8 +1965,6 @@ inttypes.h: inttypes.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(WARN_ON_U -e 's|@''NEXT_INTTYPES_H''@|$(NEXT_INTTYPES_H)|g' \ -e 's/@''PRI_MACROS_BROKEN''@/$(PRI_MACROS_BROKEN)/g' \ -e 's/@''APPLE_UNIVERSAL_BUILD''@/$(APPLE_UNIVERSAL_BUILD)/g' \ - -e 's/@''HAVE_LONG_LONG_INT''@/$(HAVE_LONG_LONG_INT)/g' \ - -e 's/@''HAVE_UNSIGNED_LONG_LONG_INT''@/$(HAVE_UNSIGNED_LONG_LONG_INT)/g' \ -e 's/@''PRIPTR_PREFIX''@/$(PRIPTR_PREFIX)/g' \ -e 's/@''GNULIB_IMAXABS''@/$(GNULIB_IMAXABS)/g' \ -e 's/@''GNULIB_IMAXDIV''@/$(GNULIB_IMAXDIV)/g' \ @@ -1941,17 +1994,51 @@ EXTRA_DIST += inttypes.in.h endif ## end gnulib module inttypes-incomplete +## begin gnulib module lchmod +ifeq (,$(OMIT_GNULIB_MODULE_lchmod)) + +ifneq (,$(gl_GNULIB_ENABLED_lchmod)) + +endif +EXTRA_DIST += lchmod.c + +EXTRA_libgnu_a_SOURCES += lchmod.c + +endif +## end gnulib module lchmod + ## begin gnulib module libc-config ifeq (,$(OMIT_GNULIB_MODULE_libc-config)) -ifneq (,$(gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467)) -endif EXTRA_DIST += cdefs.h libc-config.h endif ## end gnulib module libc-config +## begin gnulib module libgmp +ifeq (,$(OMIT_GNULIB_MODULE_libgmp)) + +BUILT_SOURCES += $(GMP_H) + +# Build gmp.h as a wrapper for mini-gmp.h when using mini-gmp. +ifneq (,$(GL_GENERATE_GMP_H)) +gmp.h: $(top_builddir)/config.status + echo '#include "mini-gmp.h"' >$@-t + mv $@-t $@ +else +gmp.h: $(top_builddir)/config.status + rm -f $@ +endif +MOSTLYCLEANFILES += gmp.h gmp.h-t + +EXTRA_DIST += mini-gmp-gnulib.c mini-gmp.c mini-gmp.h + +EXTRA_libgnu_a_SOURCES += mini-gmp-gnulib.c mini-gmp.c + +endif +## end gnulib module libgmp + ## begin gnulib module limits-h ifeq (,$(OMIT_GNULIB_MODULE_limits-h)) @@ -2167,17 +2254,6 @@ EXTRA_libgnu_a_SOURCES += pthread_sigmask.c endif ## end gnulib module pthread_sigmask -## begin gnulib module putenv -ifeq (,$(OMIT_GNULIB_MODULE_putenv)) - - -EXTRA_DIST += putenv.c - -EXTRA_libgnu_a_SOURCES += putenv.c - -endif -## end gnulib module putenv - ## begin gnulib module qcopy-acl ifeq (,$(OMIT_GNULIB_MODULE_qcopy-acl)) @@ -2432,8 +2508,6 @@ stdint.h: stdint.in.h $(top_builddir)/config.status -e 's/@''HAVE_SYS_INTTYPES_H''@/$(HAVE_SYS_INTTYPES_H)/g' \ -e 's/@''HAVE_SYS_BITYPES_H''@/$(HAVE_SYS_BITYPES_H)/g' \ -e 's/@''HAVE_WCHAR_H''@/$(HAVE_WCHAR_H)/g' \ - -e 's/@''HAVE_LONG_LONG_INT''@/$(HAVE_LONG_LONG_INT)/g' \ - -e 's/@''HAVE_UNSIGNED_LONG_LONG_INT''@/$(HAVE_UNSIGNED_LONG_LONG_INT)/g' \ -e 's/@''APPLE_UNIVERSAL_BUILD''@/$(APPLE_UNIVERSAL_BUILD)/g' \ -e 's/@''BITSIZEOF_PTRDIFF_T''@/$(BITSIZEOF_PTRDIFF_T)/g' \ -e 's/@''PTRDIFF_T_SUFFIX''@/$(PTRDIFF_T_SUFFIX)/g' \ @@ -2783,7 +2857,6 @@ string.h: string.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''HAVE_FFSL''@|$(HAVE_FFSL)|g' \ -e 's|@''HAVE_FFSLL''@|$(HAVE_FFSLL)|g' \ -e 's|@''HAVE_MBSLEN''@|$(HAVE_MBSLEN)|g' \ - -e 's|@''HAVE_MEMCHR''@|$(HAVE_MEMCHR)|g' \ -e 's|@''HAVE_DECL_MEMMEM''@|$(HAVE_DECL_MEMMEM)|g' \ -e 's|@''HAVE_MEMPCPY''@|$(HAVE_MEMPCPY)|g' \ -e 's|@''HAVE_DECL_MEMRCHR''@|$(HAVE_DECL_MEMRCHR)|g' \ @@ -2875,6 +2948,40 @@ EXTRA_libgnu_a_SOURCES += symlink.c endif ## end gnulib module symlink +## begin gnulib module sys_random +ifeq (,$(OMIT_GNULIB_MODULE_sys_random)) + +BUILT_SOURCES += sys/random.h + +# We need the following in order to create <sys/random.h> when the system +# doesn't have one. +sys/random.h: sys_random.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H) $(WARN_ON_USE_H) + $(AM_V_at)$(MKDIR_P) sys + $(AM_V_GEN)rm -f $@-t $@ && \ + { echo '/* DO NOT EDIT! GENERATED AUTOMATICALLY! */'; \ + sed -e 's|@''GUARD_PREFIX''@|GL|g' \ + -e 's|@''INCLUDE_NEXT''@|$(INCLUDE_NEXT)|g' \ + -e 's|@''PRAGMA_SYSTEM_HEADER''@|@PRAGMA_SYSTEM_HEADER@|g' \ + -e 's|@''PRAGMA_COLUMNS''@|@PRAGMA_COLUMNS@|g' \ + -e 's|@''NEXT_SYS_RANDOM_H''@|$(NEXT_SYS_RANDOM_H)|g' \ + -e 's|@''HAVE_SYS_RANDOM_H''@|$(HAVE_SYS_RANDOM_H)|g' \ + -e 's/@''GNULIB_GETRANDOM''@/$(GNULIB_GETRANDOM)/g' \ + -e 's/@''HAVE_GETRANDOM''@/$(HAVE_GETRANDOM)/g' \ + -e 's/@''REPLACE_GETRANDOM''@/$(REPLACE_GETRANDOM)/g' \ + -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ + -e '/definition of _GL_ARG_NONNULL/r $(ARG_NONNULL_H)' \ + -e '/definition of _GL_WARN_ON_USE/r $(WARN_ON_USE_H)' \ + < $(srcdir)/sys_random.in.h; \ + } > $@-t && \ + mv -f $@-t $@ +MOSTLYCLEANFILES += sys/random.h sys/random.h-t +MOSTLYCLEANDIRS += sys + +EXTRA_DIST += sys_random.in.h + +endif +## end gnulib module sys_random + ## begin gnulib module sys_select ifeq (,$(OMIT_GNULIB_MODULE_sys_select)) @@ -2933,6 +3040,7 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU -e 's/@''GNULIB_FSTAT''@/$(GNULIB_FSTAT)/g' \ -e 's/@''GNULIB_FSTATAT''@/$(GNULIB_FSTATAT)/g' \ -e 's/@''GNULIB_FUTIMENS''@/$(GNULIB_FUTIMENS)/g' \ + -e 's/@''GNULIB_GETUMASK''@/$(GNULIB_GETUMASK)/g' \ -e 's/@''GNULIB_LCHMOD''@/$(GNULIB_LCHMOD)/g' \ -e 's/@''GNULIB_LSTAT''@/$(GNULIB_LSTAT)/g' \ -e 's/@''GNULIB_MKDIRAT''@/$(GNULIB_MKDIRAT)/g' \ @@ -2946,6 +3054,7 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU -e 's|@''HAVE_FCHMODAT''@|$(HAVE_FCHMODAT)|g' \ -e 's|@''HAVE_FSTATAT''@|$(HAVE_FSTATAT)|g' \ -e 's|@''HAVE_FUTIMENS''@|$(HAVE_FUTIMENS)|g' \ + -e 's|@''HAVE_GETUMASK''@|$(HAVE_GETUMASK)|g' \ -e 's|@''HAVE_LCHMOD''@|$(HAVE_LCHMOD)|g' \ -e 's|@''HAVE_LSTAT''@|$(HAVE_LSTAT)|g' \ -e 's|@''HAVE_MKDIRAT''@|$(HAVE_MKDIRAT)|g' \ @@ -2954,6 +3063,7 @@ sys/stat.h: sys_stat.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNU -e 's|@''HAVE_MKNOD''@|$(HAVE_MKNOD)|g' \ -e 's|@''HAVE_MKNODAT''@|$(HAVE_MKNODAT)|g' \ -e 's|@''HAVE_UTIMENSAT''@|$(HAVE_UTIMENSAT)|g' \ + -e 's|@''REPLACE_FCHMODAT''@|$(REPLACE_FCHMODAT)|g' \ -e 's|@''REPLACE_FSTAT''@|$(REPLACE_FSTAT)|g' \ -e 's|@''REPLACE_FSTATAT''@|$(REPLACE_FSTATAT)|g' \ -e 's|@''REPLACE_FUTIMENS''@|$(REPLACE_FUTIMENS)|g' \ @@ -3214,10 +3324,12 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's/@''GNULIB_GETCWD''@/$(GNULIB_GETCWD)/g' \ -e 's/@''GNULIB_GETDOMAINNAME''@/$(GNULIB_GETDOMAINNAME)/g' \ -e 's/@''GNULIB_GETDTABLESIZE''@/$(GNULIB_GETDTABLESIZE)/g' \ + -e 's/@''GNULIB_GETENTROPY''@/$(GNULIB_GETENTROPY)/g' \ -e 's/@''GNULIB_GETGROUPS''@/$(GNULIB_GETGROUPS)/g' \ -e 's/@''GNULIB_GETHOSTNAME''@/$(GNULIB_GETHOSTNAME)/g' \ -e 's/@''GNULIB_GETLOGIN''@/$(GNULIB_GETLOGIN)/g' \ -e 's/@''GNULIB_GETLOGIN_R''@/$(GNULIB_GETLOGIN_R)/g' \ + -e 's/@''GNULIB_GETOPT_POSIX''@/$(GNULIB_GETOPT_POSIX)/g' \ -e 's/@''GNULIB_GETPAGESIZE''@/$(GNULIB_GETPAGESIZE)/g' \ -e 's/@''GNULIB_GETPASS''@/$(GNULIB_GETPASS)/g' \ -e 's/@''GNULIB_GETUSERSHELL''@/$(GNULIB_GETUSERSHELL)/g' \ @@ -3251,7 +3363,6 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H < $(srcdir)/unistd.in.h | \ sed -e 's|@''HAVE_CHOWN''@|$(HAVE_CHOWN)|g' \ -e 's|@''HAVE_COPY_FILE_RANGE''@|$(HAVE_COPY_FILE_RANGE)|g' \ - -e 's|@''HAVE_DUP2''@|$(HAVE_DUP2)|g' \ -e 's|@''HAVE_DUP3''@|$(HAVE_DUP3)|g' \ -e 's|@''HAVE_EUIDACCESS''@|$(HAVE_EUIDACCESS)|g' \ -e 's|@''HAVE_FACCESSAT''@|$(HAVE_FACCESSAT)|g' \ @@ -3261,6 +3372,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''HAVE_FSYNC''@|$(HAVE_FSYNC)|g' \ -e 's|@''HAVE_FTRUNCATE''@|$(HAVE_FTRUNCATE)|g' \ -e 's|@''HAVE_GETDTABLESIZE''@|$(HAVE_GETDTABLESIZE)|g' \ + -e 's|@''HAVE_GETENTROPY''@|$(HAVE_GETENTROPY)|g' \ -e 's|@''HAVE_GETGROUPS''@|$(HAVE_GETGROUPS)|g' \ -e 's|@''HAVE_GETHOSTNAME''@|$(HAVE_GETHOSTNAME)|g' \ -e 's|@''HAVE_GETPAGESIZE''@|$(HAVE_GETPAGESIZE)|g' \ @@ -3330,6 +3442,7 @@ unistd.h: unistd.in.h $(top_builddir)/config.status $(CXXDEFS_H) $(ARG_NONNULL_H -e 's|@''REPLACE_UNLINKAT''@|$(REPLACE_UNLINKAT)|g' \ -e 's|@''REPLACE_USLEEP''@|$(REPLACE_USLEEP)|g' \ -e 's|@''REPLACE_WRITE''@|$(REPLACE_WRITE)|g' \ + -e 's|@''UNISTD_H_HAVE_SYS_RANDOM_H''@|$(UNISTD_H_HAVE_SYS_RANDOM_H)|g' \ -e 's|@''UNISTD_H_HAVE_WINSOCK2_H''@|$(UNISTD_H_HAVE_WINSOCK2_H)|g' \ -e 's|@''UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS''@|$(UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS)|g' \ -e '/definitions of _GL_FUNCDECL_RPL/r $(CXXDEFS_H)' \ @@ -3365,13 +3478,26 @@ endif ## begin gnulib module utimens ifeq (,$(OMIT_GNULIB_MODULE_utimens)) +ifneq (,$(gl_GNULIB_ENABLED_utimens)) libgnu_a_SOURCES += utimens.c +endif EXTRA_DIST += utimens.h endif ## end gnulib module utimens +## begin gnulib module utimensat +ifeq (,$(OMIT_GNULIB_MODULE_utimensat)) + + +EXTRA_DIST += at-func.c utimensat.c + +EXTRA_libgnu_a_SOURCES += at-func.c utimensat.c + +endif +## end gnulib module utimensat + ## begin gnulib module verify ifeq (,$(OMIT_GNULIB_MODULE_verify)) diff --git a/lib/group-member.c b/lib/group-member.c index 7aa8a453615..6a6fc5605ef 100644 --- a/lib/group-member.c +++ b/lib/group-member.c @@ -1,7 +1,7 @@ /* group-member.c -- determine whether group id is in calling user's group list - Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2020 Free - Software Foundation, Inc. + Copyright (C) 1994, 1997-1998, 2003, 2005-2006, 2009-2020 Free Software + Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/ieee754.in.h b/lib/ieee754.in.h index 01ca648905f..d64bb46e9de 100644 --- a/lib/ieee754.in.h +++ b/lib/ieee754.in.h @@ -67,7 +67,7 @@ union ieee754_float #endif /* Little endian. */ } ieee; - /* This format makes it easier to see if a NaN is a signaling NaN. */ + /* This format makes it easier to see if a NaN is a signalling NaN. */ struct { #if __BYTE_ORDER == __BIG_ENDIAN @@ -118,7 +118,7 @@ union ieee754_double #endif /* Little endian. */ } ieee; - /* This format makes it easier to see if a NaN is a signaling NaN. */ + /* This format makes it easier to see if a NaN is a signalling NaN. */ struct { #if __BYTE_ORDER == __BIG_ENDIAN diff --git a/lib/inttypes.in.h b/lib/inttypes.in.h index da84aff0440..9f04a6ced4a 100644 --- a/lib/inttypes.in.h +++ b/lib/inttypes.in.h @@ -38,6 +38,8 @@ # endif # @INCLUDE_NEXT@ @NEXT_INTTYPES_H@ + +# define _GL_FINISHED_INCLUDING_SYSTEM_INTTYPES_H # endif #endif @@ -189,7 +191,7 @@ # define _PRI64_PREFIX "l" # elif defined _MSC_VER || defined __MINGW32__ # define _PRI64_PREFIX "I64" -# elif @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# elif LONG_MAX >> 30 == 1 # define _PRI64_PREFIX _LONG_LONG_FORMAT_PREFIX # endif # if !defined PRId64 || @PRI_MACROS_BROKEN@ @@ -206,7 +208,7 @@ # define _PRIu64_PREFIX "l" # elif defined _MSC_VER || defined __MINGW32__ # define _PRIu64_PREFIX "I64" -# elif @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# elif ULONG_MAX >> 31 == 1 # define _PRIu64_PREFIX _LONG_LONG_FORMAT_PREFIX # endif # if !defined PRIo64 || @PRI_MACROS_BROKEN@ @@ -682,7 +684,7 @@ # define _SCN64_PREFIX "l" # elif defined _MSC_VER || defined __MINGW32__ # define _SCN64_PREFIX "I64" -# elif @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# elif LONG_MAX >> 30 == 1 # define _SCN64_PREFIX _LONG_LONG_FORMAT_PREFIX # endif # if !defined SCNd64 || @PRI_MACROS_BROKEN@ @@ -699,7 +701,7 @@ # define _SCNu64_PREFIX "l" # elif defined _MSC_VER || defined __MINGW32__ # define _SCNu64_PREFIX "I64" -# elif @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# elif ULONG_MAX >> 31 == 1 # define _SCNu64_PREFIX _LONG_LONG_FORMAT_PREFIX # endif # if !defined SCNo64 || @PRI_MACROS_BROKEN@ @@ -1091,15 +1093,19 @@ _GL_WARN_ON_USE (imaxdiv, "imaxdiv is unportable - " # define strtoimax rpl_strtoimax # endif _GL_FUNCDECL_RPL (strtoimax, intmax_t, - (const char *, char **, int) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strtoimax, intmax_t, (const char *, char **, int)); + (const char *restrict, char **restrict, int) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (strtoimax, intmax_t, + (const char *restrict, char **restrict, int)); # else # if !@HAVE_DECL_STRTOIMAX@ # undef strtoimax _GL_FUNCDECL_SYS (strtoimax, intmax_t, - (const char *, char **, int) _GL_ARG_NONNULL ((1))); + (const char *restrict, char **restrict, int) + _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strtoimax, intmax_t, (const char *, char **, int)); +_GL_CXXALIAS_SYS (strtoimax, intmax_t, + (const char *restrict, char **restrict, int)); # endif _GL_CXXALIASWARN (strtoimax); #elif defined GNULIB_POSIXCHECK @@ -1117,15 +1123,19 @@ _GL_WARN_ON_USE (strtoimax, "strtoimax is unportable - " # define strtoumax rpl_strtoumax # endif _GL_FUNCDECL_RPL (strtoumax, uintmax_t, - (const char *, char **, int) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strtoumax, uintmax_t, (const char *, char **, int)); + (const char *restrict, char **restrict, int) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (strtoumax, uintmax_t, + (const char *restrict, char **restrict, int)); # else # if !@HAVE_DECL_STRTOUMAX@ # undef strtoumax _GL_FUNCDECL_SYS (strtoumax, uintmax_t, - (const char *, char **, int) _GL_ARG_NONNULL ((1))); + (const char *restrict, char **restrict, int) + _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strtoumax, uintmax_t, (const char *, char **, int)); +_GL_CXXALIAS_SYS (strtoumax, uintmax_t, + (const char *restrict, char **restrict, int)); # endif _GL_CXXALIASWARN (strtoumax); #elif defined GNULIB_POSIXCHECK diff --git a/lib/lchmod.c b/lib/lchmod.c new file mode 100644 index 00000000000..e1132116234 --- /dev/null +++ b/lib/lchmod.c @@ -0,0 +1,110 @@ +/* Implement lchmod on platforms where it does not work correctly. + + Copyright 2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* written by Paul Eggert */ + +#include <config.h> + +/* Specification. */ +#include <sys/stat.h> + +#include <errno.h> +#include <fcntl.h> +#include <stdio.h> +#include <unistd.h> + +#ifdef __osf__ +/* Write "sys/stat.h" here, not <sys/stat.h>, otherwise OSF/1 5.1 DTK cc + eliminates this include because of the preliminary #include <sys/stat.h> + above. */ +# include "sys/stat.h" +#else +# include <sys/stat.h> +#endif + +#include <intprops.h> + +/* Work like chmod, except when FILE is a symbolic link. + In that case, on systems where permissions on symbolic links are unsupported + (such as Linux), set errno to EOPNOTSUPP and return -1. */ + +int +lchmod (char const *file, mode_t mode) +{ +#if defined O_PATH && defined AT_EMPTY_PATH + /* Open a file descriptor with O_NOFOLLOW, to make sure we don't + follow symbolic links, if /proc is mounted. O_PATH is used to + avoid a failure if the file is not readable. + Cf. <https://sourceware.org/bugzilla/show_bug.cgi?id=14578> */ + int fd = open (file, O_PATH | O_NOFOLLOW | O_CLOEXEC); + if (fd < 0) + return fd; + + /* Up to Linux 5.3 at least, when FILE refers to a symbolic link, the + chmod call below will change the permissions of the symbolic link + - which is undesired - and on many file systems (ext4, btrfs, jfs, + xfs, ..., but not reiserfs) fail with error EOPNOTSUPP - which is + misleading. Therefore test for a symbolic link explicitly. + Use fstatat because fstat does not work on O_PATH descriptors + before Linux 3.6. */ + struct stat st; + if (fstatat (fd, "", &st, AT_EMPTY_PATH) != 0) + { + int stat_errno = errno; + close (fd); + errno = stat_errno; + return -1; + } + if (S_ISLNK (st.st_mode)) + { + close (fd); + errno = EOPNOTSUPP; + return -1; + } + +# if defined __linux__ || defined __ANDROID__ + static char const fmt[] = "/proc/self/fd/%d"; + char buf[sizeof fmt - sizeof "%d" + INT_BUFSIZE_BOUND (int)]; + sprintf (buf, fmt, fd); + int chmod_result = chmod (buf, mode); + int chmod_errno = errno; + close (fd); + if (chmod_result == 0) + return chmod_result; + if (chmod_errno != ENOENT) + { + errno = chmod_errno; + return chmod_result; + } +# endif + /* /proc is not mounted or would not work as in GNU/Linux. */ + +#elif HAVE_LSTAT + struct stat st; + int lstat_result = lstat (file, &st); + if (lstat_result != 0) + return lstat_result; + if (S_ISLNK (st.st_mode)) + { + errno = EOPNOTSUPP; + return -1; + } +#endif + + /* Fall back on chmod, despite a possible race. */ + return chmod (file, mode); +} diff --git a/lib/libc-config.h b/lib/libc-config.h index aef1f793242..1300c3a2ac8 100644 --- a/lib/libc-config.h +++ b/lib/libc-config.h @@ -55,8 +55,17 @@ #ifndef __glibc_clang_prereq # if defined __clang_major__ && defined __clang_minor__ -# define __glibc_clang_prereq(maj, min) \ - ((maj) < __clang_major__ + ((min) <= __clang_minor__)) +# ifdef __apple_build_version__ +/* Apple for some reason renumbers __clang_major__ and __clang_minor__. + Gnulib code uses only __glibc_clang_prereq (3, 5); map it to + 6000000 <= __apple_build_version__. Support for other calls to + __glibc_clang_prereq can be added here as needed. */ +# define __glibc_clang_prereq(maj, min) \ + ((maj) == 3 && (min) == 5 ? 6000000 <= __apple_build_version__ : 0) +# else +# define __glibc_clang_prereq(maj, min) \ + ((maj) < __clang_major__ + ((min) <= __clang_minor__)) +# endif # else # define __glibc_clang_prereq(maj, min) 0 # endif @@ -171,4 +180,5 @@ /* A substitute for glibc <shlib-compat.h>, good enough for Gnulib. */ #define SHLIB_COMPAT(lib, introduced, obsoleted) 0 -#define versioned_symbol(lib, local, symbol, version) +#define compat_symbol(lib, local, symbol, version) extern int dummy +#define versioned_symbol(lib, local, symbol, version) extern int dummy diff --git a/lib/limits.in.h b/lib/limits.in.h index 90c273fa178..d25c5237060 100644 --- a/lib/limits.in.h +++ b/lib/limits.in.h @@ -15,16 +15,32 @@ You should have received a copy of the GNU General Public License along with this program; if not, see <https://www.gnu.org/licenses/>. */ -#ifndef _@GUARD_PREFIX@_LIMITS_H - #if __GNUC__ >= 3 @PRAGMA_SYSTEM_HEADER@ #endif @PRAGMA_COLUMNS@ -/* The include_next requires a split double-inclusion guard. */ +#if defined _GL_ALREADY_INCLUDING_LIMITS_H +/* Special invocation convention: + On Haiku/x86_64, we have a sequence of nested includes + <limits.h> -> <syslimits.h> -> <limits.h>. + In this situation, LONG_MAX and INT_MAX are not yet defined, + therefore we should not attempt to define LONG_BIT. */ + #@INCLUDE_NEXT@ @NEXT_LIMITS_H@ +#else +/* Normal invocation convention. */ + +#ifndef _@GUARD_PREFIX@_LIMITS_H + +# define _GL_ALREADY_INCLUDING_LIMITS_H + +/* The include_next requires a split double-inclusion guard. */ +# @INCLUDE_NEXT@ @NEXT_LIMITS_H@ + +# undef _GL_ALREADY_INCLUDING_LIMITS_H + #ifndef _@GUARD_PREFIX@_LIMITS_H #define _@GUARD_PREFIX@_LIMITS_H @@ -102,3 +118,4 @@ #endif /* _@GUARD_PREFIX@_LIMITS_H */ #endif /* _@GUARD_PREFIX@_LIMITS_H */ +#endif diff --git a/lib/localtime-buffer.c b/lib/localtime-buffer.c index eb099ff8d84..141849c5461 100644 --- a/lib/localtime-buffer.c +++ b/lib/localtime-buffer.c @@ -1,7 +1,6 @@ /* Provide access to the last buffer returned by localtime() or gmtime(). - Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/localtime-buffer.h b/lib/localtime-buffer.h index 2552cfcffba..3801742f7ba 100644 --- a/lib/localtime-buffer.h +++ b/lib/localtime-buffer.h @@ -1,7 +1,6 @@ /* Provide access to the last buffer returned by localtime() or gmtime(). - Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 2001-2003, 2005-2007, 2009-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/malloca.c b/lib/malloca.c index 59bd74d598b..975b166daed 100644 --- a/lib/malloca.c +++ b/lib/malloca.c @@ -1,6 +1,5 @@ /* Safe automatic memory allocation. - Copyright (C) 2003, 2006-2007, 2009-2020 Free Software Foundation, - Inc. + Copyright (C) 2003, 2006-2007, 2009-2020 Free Software Foundation, Inc. Written by Bruno Haible <bruno@clisp.org>, 2003, 2018. This program is free software; you can redistribute it and/or modify diff --git a/lib/malloca.h b/lib/malloca.h index 0d0b713c7bd..cfcd4de4ad8 100644 --- a/lib/malloca.h +++ b/lib/malloca.h @@ -112,14 +112,10 @@ enum among all elementary types. */ sa_alignment_long = sa_alignof (long), sa_alignment_double = sa_alignof (double), -#if HAVE_LONG_LONG_INT sa_alignment_longlong = sa_alignof (long long), -#endif sa_alignment_longdouble = sa_alignof (long double), sa_alignment_max = ((sa_alignment_long - 1) | (sa_alignment_double - 1) -#if HAVE_LONG_LONG_INT | (sa_alignment_longlong - 1) -#endif | (sa_alignment_longdouble - 1) ) + 1 }; diff --git a/lib/md5.c b/lib/md5.c index e0f3032aec0..74cf2c3a0f7 100644 --- a/lib/md5.c +++ b/lib/md5.c @@ -1,7 +1,7 @@ /* Functions to compute MD5 message digest of files or memory blocks. according to the definition of MD5 in RFC 1321 from April 1992. - Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2020 Free - Software Foundation, Inc. + Copyright (C) 1995-1997, 1999-2001, 2005-2006, 2008-2020 Free Software + Foundation, Inc. This file is part of the GNU C Library. This program is free software; you can redistribute it and/or modify it diff --git a/lib/md5.h b/lib/md5.h index 7c827b0586a..3c6048242b0 100644 --- a/lib/md5.h +++ b/lib/md5.h @@ -1,7 +1,7 @@ /* Declaration of functions and data types used for MD5 sum computing library functions. - Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2020 Free - Software Foundation, Inc. + Copyright (C) 1995-1997, 1999-2001, 2004-2006, 2008-2020 Free Software + Foundation, Inc. This file is part of the GNU C Library. This program is free software; you can redistribute it and/or modify it @@ -105,13 +105,15 @@ extern void __md5_process_bytes (const void *buffer, size_t len, in first 16 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *__md5_finish_ctx (struct md5_ctx *ctx, void *resbuf) __THROW; +extern void *__md5_finish_ctx (struct md5_ctx *ctx, void *restrict resbuf) + __THROW; /* Put result from CTX in first 16 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *__md5_read_ctx (const struct md5_ctx *ctx, void *resbuf) __THROW; +extern void *__md5_read_ctx (const struct md5_ctx *ctx, void *restrict resbuf) + __THROW; /* Compute MD5 message digest for LEN bytes beginning at BUFFER. The @@ -119,7 +121,7 @@ extern void *__md5_read_ctx (const struct md5_ctx *ctx, void *resbuf) __THROW; output yields to the wanted ASCII representation of the message digest. */ extern void *__md5_buffer (const char *buffer, size_t len, - void *resblock) __THROW; + void *restrict resblock) __THROW; # endif /* Compute MD5 message digest for bytes read from STREAM. diff --git a/lib/memmem.c b/lib/memmem.c index 9108f6f697c..6f6574211f8 100644 --- a/lib/memmem.c +++ b/lib/memmem.c @@ -1,5 +1,5 @@ -/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2020 Free - Software Foundation, Inc. +/* Copyright (C) 1991-1994, 1996-1998, 2000, 2004, 2007-2020 Free Software + Foundation, Inc. This file is part of the GNU C Library. This program is free software; you can redistribute it and/or modify diff --git a/lib/memrchr.c b/lib/memrchr.c index b4256edcbb9..7ff32e11338 100644 --- a/lib/memrchr.c +++ b/lib/memrchr.c @@ -1,7 +1,7 @@ /* memrchr -- find the last occurrence of a byte in a memory block - Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2020 Free - Software Foundation, Inc. + Copyright (C) 1991, 1993, 1996-1997, 1999-2000, 2003-2020 Free Software + Foundation, Inc. Based on strlen implementation by Torbjorn Granlund (tege@sics.se), with help from Dan Sahlin (dan@sics.se) and diff --git a/lib/mini-gmp-gnulib.c b/lib/mini-gmp-gnulib.c new file mode 100644 index 00000000000..5019be5d52a --- /dev/null +++ b/lib/mini-gmp-gnulib.c @@ -0,0 +1,37 @@ +/* Tailor mini-gmp.c for Gnulib-using applications. + + Copyright 2018-2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +#include <config.h> + +#include <stddef.h> +#include <stdio.h> + +#include "mini-gmp.h" + +/* Pacify GCC -Wsuggest-attribute=const, malloc, pure. */ +#if 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +# pragma GCC diagnostic ignored "-Wsuggest-attribute=const" +# pragma GCC diagnostic ignored "-Wsuggest-attribute=malloc" +# pragma GCC diagnostic ignored "-Wsuggest-attribute=pure" +#endif + +/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */ +#if defined NDEBUG && 4 < __GNUC__ + (6 <= __GNUC_MINOR__) +# pragma GCC diagnostic ignored "-Wunused-variable" +#endif + +#include "mini-gmp.c" diff --git a/src/mini-gmp.c b/lib/mini-gmp.c index bf8a6164981..2e0301b0081 100644 --- a/src/mini-gmp.c +++ b/lib/mini-gmp.c @@ -2,21 +2,21 @@ Contributed to the GNU project by Niels Möller -Copyright 1991-1997, 1999-2019 Free Software Foundation, Inc. +Copyright 1991-1997, 1999-2020 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: - * the GNU Lesser General Public License as published by the Free + * the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software - Foundation; either version 2 of the License, or (at your option) any + Foundation; either version 3 of the License, or (at your option) any later version. or both in parallel, as here. @@ -27,7 +27,7 @@ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the -GNU Lesser General Public License along with the GNU MP Library. If not, +GNU General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* NOTE: All functions in this file which are not declared in @@ -94,11 +94,13 @@ see https://www.gnu.org/licenses/. */ #define gmp_clz(count, x) do { \ mp_limb_t __clz_x = (x); \ - unsigned __clz_c; \ - for (__clz_c = 0; \ - (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ - __clz_c += 8) \ - __clz_x <<= 8; \ + unsigned __clz_c = 0; \ + int LOCAL_SHIFT_BITS = 8; \ + if (GMP_LIMB_BITS > LOCAL_SHIFT_BITS) \ + for (; \ + (__clz_x & ((mp_limb_t) 0xff << (GMP_LIMB_BITS - 8))) == 0; \ + __clz_c += 8) \ + { __clz_x <<= LOCAL_SHIFT_BITS; } \ for (; (__clz_x & GMP_LIMB_HIGHBIT) == 0; __clz_c++) \ __clz_x <<= 1; \ (count) = __clz_c; \ @@ -143,27 +145,27 @@ see https://www.gnu.org/licenses/. */ w1 = (mp_limb_t) (__ww >> LOCAL_GMP_LIMB_BITS); \ } \ else { \ - mp_limb_t __x0, __x1, __x2, __x3; \ - unsigned __ul, __vl, __uh, __vh; \ - mp_limb_t __u = (u), __v = (v); \ + mp_limb_t __x0, __x1, __x2, __x3; \ + unsigned __ul, __vl, __uh, __vh; \ + mp_limb_t __u = (u), __v = (v); \ \ - __ul = __u & GMP_LLIMB_MASK; \ - __uh = __u >> (GMP_LIMB_BITS / 2); \ - __vl = __v & GMP_LLIMB_MASK; \ - __vh = __v >> (GMP_LIMB_BITS / 2); \ + __ul = __u & GMP_LLIMB_MASK; \ + __uh = __u >> (GMP_LIMB_BITS / 2); \ + __vl = __v & GMP_LLIMB_MASK; \ + __vh = __v >> (GMP_LIMB_BITS / 2); \ \ - __x0 = (mp_limb_t) __ul * __vl; \ - __x1 = (mp_limb_t) __ul * __vh; \ - __x2 = (mp_limb_t) __uh * __vl; \ - __x3 = (mp_limb_t) __uh * __vh; \ + __x0 = (mp_limb_t) __ul * __vl; \ + __x1 = (mp_limb_t) __ul * __vh; \ + __x2 = (mp_limb_t) __uh * __vl; \ + __x3 = (mp_limb_t) __uh * __vh; \ \ - __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ - __x1 += __x2; /* but this indeed can */ \ - if (__x1 < __x2) /* did we get it? */ \ - __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ + __x1 += __x0 >> (GMP_LIMB_BITS / 2);/* this can't give carry */ \ + __x1 += __x2; /* but this indeed can */ \ + if (__x1 < __x2) /* did we get it? */ \ + __x3 += GMP_HLIMB_BIT; /* yes, add it in the proper pos. */ \ \ - (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ - (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ + (w1) = __x3 + (__x1 >> (GMP_LIMB_BITS / 2)); \ + (w0) = (__x1 << (GMP_LIMB_BITS / 2)) + (__x0 & GMP_LLIMB_MASK); \ } \ } while (0) @@ -349,20 +351,27 @@ mp_set_memory_functions (void *(*alloc_func) (size_t), gmp_free_func = free_func; } -#define gmp_xalloc(size) ((*gmp_allocate_func)((size))) -#define gmp_free(p) ((*gmp_free_func) ((p), 0)) +#define gmp_alloc(size) ((*gmp_allocate_func)((size))) +#define gmp_free(p, size) ((*gmp_free_func) ((p), (size))) +#define gmp_realloc(ptr, old_size, size) ((*gmp_reallocate_func)(ptr, old_size, size)) static mp_ptr -gmp_xalloc_limbs (mp_size_t size) +gmp_alloc_limbs (mp_size_t size) { - return (mp_ptr) gmp_xalloc (size * sizeof (mp_limb_t)); + return (mp_ptr) gmp_alloc (size * sizeof (mp_limb_t)); } static mp_ptr -gmp_xrealloc_limbs (mp_ptr old, mp_size_t size) +gmp_realloc_limbs (mp_ptr old, mp_size_t old_size, mp_size_t size) { assert (size > 0); - return (mp_ptr) (*gmp_reallocate_func) (old, 0, size * sizeof (mp_limb_t)); + return (mp_ptr) gmp_realloc (old, old_size * sizeof (mp_limb_t), size * sizeof (mp_limb_t)); +} + +static void +gmp_free_limbs (mp_ptr old, mp_size_t size) +{ + gmp_free (old, size * sizeof (mp_limb_t)); } @@ -768,91 +777,81 @@ mpn_neg (mp_ptr rp, mp_srcptr up, mp_size_t n) mp_limb_t mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) { - int GMP_LIMB_BITS_MUL_3 = GMP_LIMB_BITS * 3; - if (sizeof (unsigned) * CHAR_BIT > GMP_LIMB_BITS * 3) - { - return (((unsigned) 1 << GMP_LIMB_BITS_MUL_3) - 1) / - (((unsigned) u1 << GMP_LIMB_BITS_MUL_3 / 3) + u0); - } - else if (GMP_ULONG_BITS > GMP_LIMB_BITS * 3) - { - return (((unsigned long) 1 << GMP_LIMB_BITS_MUL_3) - 1) / - (((unsigned long) u1 << GMP_LIMB_BITS_MUL_3 / 3) + u0); - } - else { - mp_limb_t r, p, m, ql; - unsigned ul, uh, qh; + mp_limb_t r, m; - assert (u1 >= GMP_LIMB_HIGHBIT); + { + mp_limb_t p, ql; + unsigned ul, uh, qh; - /* For notation, let b denote the half-limb base, so that B = b^2. - Split u1 = b uh + ul. */ - ul = u1 & GMP_LLIMB_MASK; - uh = u1 >> (GMP_LIMB_BITS / 2); + /* For notation, let b denote the half-limb base, so that B = b^2. + Split u1 = b uh + ul. */ + ul = u1 & GMP_LLIMB_MASK; + uh = u1 >> (GMP_LIMB_BITS / 2); - /* Approximation of the high half of quotient. Differs from the 2/1 - inverse of the half limb uh, since we have already subtracted - u0. */ - qh = ~u1 / uh; + /* Approximation of the high half of quotient. Differs from the 2/1 + inverse of the half limb uh, since we have already subtracted + u0. */ + qh = (u1 ^ GMP_LIMB_MAX) / uh; - /* Adjust to get a half-limb 3/2 inverse, i.e., we want + /* Adjust to get a half-limb 3/2 inverse, i.e., we want - qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u - = floor( (b (~u) + b-1) / u), + qh' = floor( (b^3 - 1) / u) - b = floor ((b^3 - b u - 1) / u + = floor( (b (~u) + b-1) / u), - and the remainder + and the remainder - r = b (~u) + b-1 - qh (b uh + ul) + r = b (~u) + b-1 - qh (b uh + ul) = b (~u - qh uh) + b-1 - qh ul - Subtraction of qh ul may underflow, which implies adjustments. - But by normalization, 2 u >= B > qh ul, so we need to adjust by - at most 2. - */ + Subtraction of qh ul may underflow, which implies adjustments. + But by normalization, 2 u >= B > qh ul, so we need to adjust by + at most 2. + */ - r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; + r = ((~u1 - (mp_limb_t) qh * uh) << (GMP_LIMB_BITS / 2)) | GMP_LLIMB_MASK; - p = (mp_limb_t) qh * ul; - /* Adjustment steps taken from udiv_qrnnd_c */ - if (r < p) - { - qh--; - r += u1; - if (r >= u1) /* i.e. we didn't get carry when adding to r */ - if (r < p) - { - qh--; - r += u1; - } - } - r -= p; + p = (mp_limb_t) qh * ul; + /* Adjustment steps taken from udiv_qrnnd_c */ + if (r < p) + { + qh--; + r += u1; + if (r >= u1) /* i.e. we didn't get carry when adding to r */ + if (r < p) + { + qh--; + r += u1; + } + } + r -= p; - /* Low half of the quotient is + /* Low half of the quotient is ql = floor ( (b r + b-1) / u1). - This is a 3/2 division (on half-limbs), for which qh is a - suitable inverse. */ + This is a 3/2 division (on half-limbs), for which qh is a + suitable inverse. */ - p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; - /* Unlike full-limb 3/2, we can add 1 without overflow. For this to - work, it is essential that ql is a full mp_limb_t. */ - ql = (p >> (GMP_LIMB_BITS / 2)) + 1; + p = (r >> (GMP_LIMB_BITS / 2)) * qh + r; + /* Unlike full-limb 3/2, we can add 1 without overflow. For this to + work, it is essential that ql is a full mp_limb_t. */ + ql = (p >> (GMP_LIMB_BITS / 2)) + 1; - /* By the 3/2 trick, we don't need the high half limb. */ - r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; + /* By the 3/2 trick, we don't need the high half limb. */ + r = (r << (GMP_LIMB_BITS / 2)) + GMP_LLIMB_MASK - ql * u1; - if (r >= (p << (GMP_LIMB_BITS / 2))) - { - ql--; - r += u1; - } - m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; - if (r >= u1) - { - m++; - r -= u1; - } + if (r >= (GMP_LIMB_MAX & (p << (GMP_LIMB_BITS / 2)))) + { + ql--; + r += u1; + } + m = ((mp_limb_t) qh << (GMP_LIMB_BITS / 2)) + ql; + if (r >= u1) + { + m++; + r -= u1; + } + } /* Now m is the 2/1 inverse of u1. If u0 > 0, adjust it to become a 3/2 inverse. */ @@ -881,7 +880,6 @@ mpn_invert_3by2 (mp_limb_t u1, mp_limb_t u0) } return m; - } } struct gmp_div_inverse @@ -965,11 +963,17 @@ mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, mp_limb_t d, di; mp_limb_t r; mp_ptr tp = NULL; + mp_size_t tn = 0; if (inv->shift > 0) { /* Shift, reusing qp area if possible. In-place shift if qp == np. */ - tp = qp ? qp : gmp_xalloc_limbs (nn); + tp = qp; + if (!tp) + { + tn = nn; + tp = gmp_alloc_limbs (tn); + } r = mpn_lshift (tp, np, nn, inv->shift); np = tp; } @@ -986,8 +990,8 @@ mpn_div_qr_1_preinv (mp_ptr qp, mp_srcptr np, mp_size_t nn, if (qp) qp[nn] = q; } - if ((inv->shift > 0) && (tp != qp)) - gmp_free (tp); + if (tn) + gmp_free_limbs (tp, tn); return r >> inv->shift; } @@ -1145,13 +1149,13 @@ mpn_div_qr (mp_ptr qp, mp_ptr np, mp_size_t nn, mp_srcptr dp, mp_size_t dn) mpn_div_qr_invert (&inv, dp, dn); if (dn > 2 && inv.shift > 0) { - tp = gmp_xalloc_limbs (dn); + tp = gmp_alloc_limbs (dn); gmp_assert_nocarry (mpn_lshift (tp, dp, dn, inv.shift)); dp = tp; } mpn_div_qr_preinv (qp, np, nn, dp, dn, &inv); if (tp) - gmp_free (tp); + gmp_free_limbs (tp, dn); } @@ -1437,14 +1441,14 @@ mpz_init2 (mpz_t r, mp_bitcnt_t bits) r->_mp_alloc = rn; r->_mp_size = 0; - r->_mp_d = gmp_xalloc_limbs (rn); + r->_mp_d = gmp_alloc_limbs (rn); } void mpz_clear (mpz_t r) { if (r->_mp_alloc) - gmp_free (r->_mp_d); + gmp_free_limbs (r->_mp_d, r->_mp_alloc); } static mp_ptr @@ -1453,9 +1457,9 @@ mpz_realloc (mpz_t r, mp_size_t size) size = GMP_MAX (size, 1); if (r->_mp_alloc) - r->_mp_d = gmp_xrealloc_limbs (r->_mp_d, size); + r->_mp_d = gmp_realloc_limbs (r->_mp_d, r->_mp_alloc, size); else - r->_mp_d = gmp_xalloc_limbs (size); + r->_mp_d = gmp_alloc_limbs (size); r->_mp_alloc = size; if (GMP_ABS (r->_mp_size) > size) @@ -1550,8 +1554,7 @@ mpz_init_set (mpz_t r, const mpz_t x) int mpz_fits_slong_p (const mpz_t u) { - return (LONG_MAX + LONG_MIN == 0 || mpz_cmp_ui (u, LONG_MAX) <= 0) && - mpz_cmpabs_ui (u, GMP_NEG_CAST (unsigned long int, LONG_MIN)) <= 0; + return mpz_cmp_si (u, LONG_MAX) <= 0 && mpz_cmp_si (u, LONG_MIN) >= 0; } static int @@ -1574,6 +1577,30 @@ mpz_fits_ulong_p (const mpz_t u) return us >= 0 && mpn_absfits_ulong_p (u->_mp_d, us); } +int +mpz_fits_sint_p (const mpz_t u) +{ + return mpz_cmp_si (u, INT_MAX) <= 0 && mpz_cmp_si (u, INT_MIN) >= 0; +} + +int +mpz_fits_uint_p (const mpz_t u) +{ + return u->_mp_size >= 0 && mpz_cmpabs_ui (u, UINT_MAX) <= 0; +} + +int +mpz_fits_sshort_p (const mpz_t u) +{ + return mpz_cmp_si (u, SHRT_MAX) <= 0 && mpz_cmp_si (u, SHRT_MIN) >= 0; +} + +int +mpz_fits_ushort_p (const mpz_t u) +{ + return u->_mp_size >= 0 && mpz_cmpabs_ui (u, USHRT_MAX) <= 0; +} + long int mpz_get_si (const mpz_t u) { @@ -3082,7 +3109,7 @@ mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) one, using a *normalized* m. */ minv.shift = 0; - tp = gmp_xalloc_limbs (mn); + tp = gmp_alloc_limbs (mn); gmp_assert_nocarry (mpn_lshift (tp, mp, mn, shift)); mp = tp; } @@ -3148,7 +3175,7 @@ mpz_powm (mpz_t r, const mpz_t b, const mpz_t e, const mpz_t m) tr->_mp_size = mpn_normalized_size (tr->_mp_d, mn); } if (tp) - gmp_free (tp); + gmp_free_limbs (tp, mn); mpz_swap (r, tr); mpz_clear (tr); @@ -3332,7 +3359,7 @@ mpz_bin_uiui (mpz_t r, unsigned long n, unsigned long k) mpz_fac_ui (t, k); for (; k > 0; --k) - mpz_mul_ui (r, r, n--); + mpz_mul_ui (r, r, n--); mpz_divexact (r, r, t); mpz_clear (t); @@ -3359,13 +3386,15 @@ gmp_jacobi_coprime (mp_limb_t a, mp_limb_t b) gmp_ctz(c, a); a >>= 1; - do + for (;;) { a >>= c; /* (2/b) = -1 if b = 3 or 5 mod 8 */ bit ^= c & (b ^ (b >> 1)); if (a < b) { + if (a == 0) + return bit & 1 ? -1 : 1; bit ^= a & b; a = b - a; b -= a; @@ -3379,9 +3408,6 @@ gmp_jacobi_coprime (mp_limb_t a, mp_limb_t b) gmp_ctz(c, a); ++c; } - while (b > 0); - - return bit & 1 ? -1 : 1; } static void @@ -3990,13 +4016,18 @@ gmp_popcount_limb (mp_limb_t x) unsigned c; /* Do 16 bits at a time, to avoid limb-sized constants. */ - for (c = 0; x > 0; x >>= 16) + int LOCAL_SHIFT_BITS = 16; + for (c = 0; x > 0;) { unsigned w = x - ((x >> 1) & 0x5555); w = ((w >> 2) & 0x3333) + (w & 0x3333); w = (w >> 4) + w; w = ((w >> 8) & 0x000f) + (w & 0x000f); c += w; + if (GMP_LIMB_BITS > LOCAL_SHIFT_BITS) + x >>= LOCAL_SHIFT_BITS; + else + x = 0; } return c; } @@ -4148,7 +4179,7 @@ mpz_scan0 (const mpz_t u, mp_bitcnt_t starting_bit) size_t mpz_sizeinbase (const mpz_t u, int base) { - mp_size_t un; + mp_size_t un, tn; mp_srcptr up; mp_ptr tp; mp_bitcnt_t bits; @@ -4181,20 +4212,21 @@ mpz_sizeinbase (const mpz_t u, int base) 10. */ } - tp = gmp_xalloc_limbs (un); + tp = gmp_alloc_limbs (un); mpn_copyi (tp, up, un); mpn_div_qr_1_invert (&bi, base); + tn = un; ndigits = 0; do { ndigits++; - mpn_div_qr_1_preinv (tp, tp, un, &bi); - un -= (tp[un-1] == 0); + mpn_div_qr_1_preinv (tp, tp, tn, &bi); + tn -= (tp[tn-1] == 0); } - while (un > 0); + while (tn > 0); - gmp_free (tp); + gmp_free_limbs (tp, un); return ndigits; } @@ -4204,7 +4236,7 @@ mpz_get_str (char *sp, int base, const mpz_t u) unsigned bits; const char *digits; mp_size_t un; - size_t i, sn; + size_t i, sn, osn; digits = "0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; if (base > 1) @@ -4225,15 +4257,19 @@ mpz_get_str (char *sp, int base, const mpz_t u) sn = 1 + mpz_sizeinbase (u, base); if (!sp) - sp = (char *) gmp_xalloc (1 + sn); - + { + osn = 1 + sn; + sp = (char *) gmp_alloc (osn); + } + else + osn = 0; un = GMP_ABS (u->_mp_size); if (un == 0) { sp[0] = '0'; - sp[1] = '\0'; - return sp; + sn = 1; + goto ret; } i = 0; @@ -4252,17 +4288,20 @@ mpz_get_str (char *sp, int base, const mpz_t u) mp_ptr tp; mpn_get_base_info (&info, base); - tp = gmp_xalloc_limbs (un); + tp = gmp_alloc_limbs (un); mpn_copyi (tp, u->_mp_d, un); sn = i + mpn_get_str_other ((unsigned char *) sp + i, base, &info, tp, un); - gmp_free (tp); + gmp_free_limbs (tp, un); } for (; i < sn; i++) sp[i] = digits[(unsigned char) sp[i]]; +ret: sp[sn] = '\0'; + if (osn && osn != sn + 1) + sp = gmp_realloc(sp, osn, sn + 1); return sp; } @@ -4272,7 +4311,7 @@ mpz_set_str (mpz_t r, const char *sp, int base) unsigned bits, value_of_a; mp_size_t rn, alloc; mp_ptr rp; - size_t dn; + size_t dn, sn; int sign; unsigned char *dp; @@ -4310,7 +4349,8 @@ mpz_set_str (mpz_t r, const char *sp, int base) r->_mp_size = 0; return -1; } - dp = (unsigned char *) gmp_xalloc (strlen (sp)); + sn = strlen(sp); + dp = (unsigned char *) gmp_alloc (sn); value_of_a = (base > 36) ? 36 : 10; for (dn = 0; *sp; sp++) @@ -4330,7 +4370,7 @@ mpz_set_str (mpz_t r, const char *sp, int base) if (digit >= (unsigned) base) { - gmp_free (dp); + gmp_free (dp, sn); r->_mp_size = 0; return -1; } @@ -4340,7 +4380,7 @@ mpz_set_str (mpz_t r, const char *sp, int base) if (!dn) { - gmp_free (dp); + gmp_free (dp, sn); r->_mp_size = 0; return -1; } @@ -4364,7 +4404,7 @@ mpz_set_str (mpz_t r, const char *sp, int base) rn -= rp[rn-1] == 0; } assert (rn <= alloc); - gmp_free (dp); + gmp_free (dp, sn); r->_mp_size = sign ? - rn : rn; @@ -4382,13 +4422,13 @@ size_t mpz_out_str (FILE *stream, int base, const mpz_t x) { char *str; - size_t len; + size_t len, n; str = mpz_get_str (NULL, base, x); len = strlen (str); - len = fwrite (str, 1, len, stream); - gmp_free (str); - return len; + n = fwrite (str, 1, len, stream); + gmp_free (str, len + 1); + return n; } @@ -4503,15 +4543,20 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian, limb = u->_mp_d[un-1]; assert (limb != 0); - k = 0; - do { - k++; limb >>= CHAR_BIT; - } while (limb != 0); + k = (GMP_LIMB_BITS <= CHAR_BIT); + if (!k) + { + do { + int LOCAL_CHAR_BIT = CHAR_BIT; + k++; limb >>= LOCAL_CHAR_BIT; + } while (limb != 0); + } + /* else limb = 0; */ count = (k + (un-1) * sizeof (mp_limb_t) + size - 1) / size; if (!r) - r = gmp_xalloc (count * size); + r = gmp_alloc (count * size); if (endian == 0) endian = gmp_detect_endian (); @@ -4535,17 +4580,28 @@ mpz_export (void *r, size_t *countp, int order, size_t size, int endian, for (bytes = 0, i = 0, k = 0; k < count; k++, p += word_step) { size_t j; - for (j = 0; j < size; j++, p -= (ptrdiff_t) endian) + for (j = 0; j < size; ++j, p -= (ptrdiff_t) endian) { - if (bytes == 0) + if (sizeof (mp_limb_t) == 1) { if (i < un) - limb = u->_mp_d[i++]; - bytes = sizeof (mp_limb_t); + *p = u->_mp_d[i++]; + else + *p = 0; + } + else + { + int LOCAL_CHAR_BIT = CHAR_BIT; + if (bytes == 0) + { + if (i < un) + limb = u->_mp_d[i++]; + bytes = sizeof (mp_limb_t); + } + *p = limb; + limb >>= LOCAL_CHAR_BIT; + bytes--; } - *p = limb; - limb >>= CHAR_BIT; - bytes--; } } assert (i == un); diff --git a/src/mini-gmp.h b/lib/mini-gmp.h index 27e0c0671a2..c00568c2568 100644 --- a/src/mini-gmp.h +++ b/lib/mini-gmp.h @@ -1,20 +1,20 @@ /* mini-gmp, a minimalistic implementation of a GNU GMP subset. -Copyright 2011-2015, 2017 Free Software Foundation, Inc. +Copyright 2011-2015, 2017, 2019 Free Software Foundation, Inc. This file is part of the GNU MP Library. The GNU MP Library is free software; you can redistribute it and/or modify it under the terms of either: - * the GNU Lesser General Public License as published by the Free + * the GNU General Public License as published by the Free Software Foundation; either version 3 of the License, or (at your option) any later version. or * the GNU General Public License as published by the Free Software - Foundation; either version 2 of the License, or (at your option) any + Foundation; either version 3 of the License, or (at your option) any later version. or both in parallel, as here. @@ -25,7 +25,7 @@ or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received copies of the GNU General Public License and the -GNU Lesser General Public License along with the GNU MP Library. If not, +GNU General Public License along with the GNU MP Library. If not, see https://www.gnu.org/licenses/. */ /* About mini-gmp: This is a minimal implementation of a subset of the @@ -53,7 +53,11 @@ void mp_get_memory_functions (void *(**) (size_t), void *(**) (void *, size_t, size_t), void (**) (void *, size_t)); -typedef unsigned long mp_limb_t; +#ifndef MINI_GMP_LIMB_TYPE +#define MINI_GMP_LIMB_TYPE long +#endif + +typedef unsigned MINI_GMP_LIMB_TYPE mp_limb_t; typedef long mp_size_t; typedef unsigned long mp_bitcnt_t; @@ -240,6 +244,10 @@ mp_bitcnt_t mpz_scan1 (const mpz_t, mp_bitcnt_t); int mpz_fits_slong_p (const mpz_t); int mpz_fits_ulong_p (const mpz_t); +int mpz_fits_sint_p (const mpz_t); +int mpz_fits_uint_p (const mpz_t); +int mpz_fits_sshort_p (const mpz_t); +int mpz_fits_ushort_p (const mpz_t); long int mpz_get_si (const mpz_t); unsigned long int mpz_get_ui (const mpz_t); double mpz_get_d (const mpz_t); diff --git a/lib/mktime.c b/lib/mktime.c index a13fa27e2bc..92c00b2b14b 100644 --- a/lib/mktime.c +++ b/lib/mktime.c @@ -141,7 +141,7 @@ shr (long_int a, int b) long_int one = 1; return (-one >> 1 == -1 ? a >> b - : a / (one << b) - (a % (one << b) < 0)); + : (a + (a < 0)) / (one << b) - (a < 0)); } /* Bounds for the intersection of __time64_t and long_int. */ @@ -211,8 +211,8 @@ ydhms_diff (long_int year1, long_int yday1, int hour1, int min1, int sec1, Take care to avoid integer overflow here. */ int a4 = shr (year1, 2) + shr (TM_YEAR_BASE, 2) - ! (year1 & 3); int b4 = shr (year0, 2) + shr (TM_YEAR_BASE, 2) - ! (year0 & 3); - int a100 = a4 / 25 - (a4 % 25 < 0); - int b100 = b4 / 25 - (b4 % 25 < 0); + int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0); + int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0); int a400 = shr (a100, 2); int b400 = shr (b100, 2); int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); diff --git a/lib/nstrftime.c b/lib/nstrftime.c index 667c7ddc56e..28b539dc2f2 100644 --- a/lib/nstrftime.c +++ b/lib/nstrftime.c @@ -68,16 +68,9 @@ extern char *tzname[]; #include <string.h> #include <stdbool.h> +#include "attribute.h" #include <intprops.h> -#ifndef FALLTHROUGH -# if __GNUC__ < 7 -# define FALLTHROUGH ((void) 0) -# else -# define FALLTHROUGH __attribute__ ((__fallthrough__)) -# endif -#endif - #ifdef COMPILE_WIDE # include <endian.h> # define CHAR_T wchar_t @@ -113,7 +106,7 @@ extern char *tzname[]; #define SHR(a, b) \ (-1 >> 1 == -1 \ ? (a) >> (b) \ - : (a) / (1 << (b)) - ((a) % (1 << (b)) < 0)) + : ((a) + ((a) < 0)) / (1 << (b)) - ((a) < 0)) #define TM_YEAR_BASE 1900 @@ -348,8 +341,8 @@ tm_diff (const struct tm *a, const struct tm *b) but it's OK to assume that A and B are close to each other. */ int a4 = SHR (a->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (a->tm_year & 3); int b4 = SHR (b->tm_year, 2) + SHR (TM_YEAR_BASE, 2) - ! (b->tm_year & 3); - int a100 = a4 / 25 - (a4 % 25 < 0); - int b100 = b4 / 25 - (b4 % 25 < 0); + int a100 = (a4 + (a4 < 0)) / 25 - (a4 < 0); + int b100 = (b4 + (b4 < 0)) / 25 - (b4 < 0); int a400 = SHR (a100, 2); int b400 = SHR (b100, 2); int intervening_leap_days = (a4 - b4) - (a100 - b100) + (a400 - b400); @@ -927,9 +920,11 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) } { - int century = tp->tm_year / 100 + TM_YEAR_BASE / 100; - century -= tp->tm_year % 100 < 0 && 0 < century; - DO_YEARISH (2, tp->tm_year < - TM_YEAR_BASE, century); + bool negative_year = tp->tm_year < - TM_YEAR_BASE; + bool zero_thru_1899 = !negative_year & (tp->tm_year < 0); + int century = ((tp->tm_year - 99 * zero_thru_1899) / 100 + + TM_YEAR_BASE / 100); + DO_YEARISH (2, negative_year, century); } case L_('x'): @@ -1138,8 +1133,8 @@ __strftime_internal (STREAM_OR_CHAR_T *s, STRFTIME_ARG (size_t maxsize) int ndigs = ns_digits; while (width < ndigs || (1 < ndigs && n % 10 == 0)) ndigs--, n /= 10; - for (int i = ndigs; 0 < i; i--) - buf[i - 1] = n % 10 + L_('0'), n /= 10; + for (int j = ndigs; 0 < j; j--) + buf[j - 1] = n % 10 + L_('0'), n /= 10; if (!pad) pad = L_('0'); width_cpy (0, ndigs, buf); diff --git a/lib/open.c b/lib/open.c index 487194f6652..751b42d7dcf 100644 --- a/lib/open.c +++ b/lib/open.c @@ -110,7 +110,9 @@ open (const char *filename, int flags, ...) directories, - if O_WRONLY or O_RDWR is specified, open() must fail because the file does not contain a '.' directory. */ - if (flags & (O_CREAT | O_WRONLY | O_RDWR)) + if ((flags & O_CREAT) + || (flags & O_ACCMODE) == O_RDWR + || (flags & O_ACCMODE) == O_WRONLY) { size_t len = strlen (filename); if (len > 0 && filename[len - 1] == '/') @@ -122,7 +124,7 @@ open (const char *filename, int flags, ...) #endif fd = orig_open (filename, - flags & ~(have_cloexec <= 0 ? O_CLOEXEC : 0), mode); + flags & ~(have_cloexec < 0 ? O_CLOEXEC : 0), mode); if (flags & O_CLOEXEC) { diff --git a/lib/openat-proc.c b/lib/openat-proc.c index 9111cd3d7ee..b5aaee8b1d3 100644 --- a/lib/openat-proc.c +++ b/lib/openat-proc.c @@ -73,8 +73,9 @@ openat_proc_name (char buf[OPENAT_BUFFER_SIZE], int fd, char const *file) problem is exhibited on code that built on Solaris 8 and running on Solaris 10. */ - int proc_self_fd = open ("/proc/self/fd", - O_SEARCH | O_DIRECTORY | O_NOCTTY | O_NONBLOCK); + int proc_self_fd = + open ("/proc/self/fd", + O_SEARCH | O_DIRECTORY | O_NOCTTY | O_NONBLOCK | O_CLOEXEC); if (proc_self_fd < 0) proc_status = -1; else diff --git a/lib/openat.h b/lib/openat.h index 7589150f34f..824ce560e34 100644 --- a/lib/openat.h +++ b/lib/openat.h @@ -52,19 +52,19 @@ _Noreturn void openat_save_fail (int); slightly more readable than it would be with fchownat (..., 0) or fchownat (..., AT_SYMLINK_NOFOLLOW). */ -#if GNULIB_FCHOWNAT +#if GNULIB_CHOWNAT -# ifndef FCHOWNAT_INLINE -# define FCHOWNAT_INLINE _GL_INLINE +# ifndef CHOWNAT_INLINE +# define CHOWNAT_INLINE _GL_INLINE # endif -FCHOWNAT_INLINE int +CHOWNAT_INLINE int chownat (int fd, char const *file, uid_t owner, gid_t group) { return fchownat (fd, file, owner, group, 0); } -FCHOWNAT_INLINE int +CHOWNAT_INLINE int lchownat (int fd, char const *file, uid_t owner, gid_t group) { return fchownat (fd, file, owner, group, AT_SYMLINK_NOFOLLOW); @@ -72,19 +72,19 @@ lchownat (int fd, char const *file, uid_t owner, gid_t group) #endif -#if GNULIB_FCHMODAT +#if GNULIB_CHMODAT -# ifndef FCHMODAT_INLINE -# define FCHMODAT_INLINE _GL_INLINE +# ifndef CHMODAT_INLINE +# define CHMODAT_INLINE _GL_INLINE # endif -FCHMODAT_INLINE int +CHMODAT_INLINE int chmodat (int fd, char const *file, mode_t mode) { return fchmodat (fd, file, mode, 0); } -FCHMODAT_INLINE int +CHMODAT_INLINE int lchmodat (int fd, char const *file, mode_t mode) { return fchmodat (fd, file, mode, AT_SYMLINK_NOFOLLOW); diff --git a/lib/putenv.c b/lib/putenv.c deleted file mode 100644 index 9e862e63d3d..00000000000 --- a/lib/putenv.c +++ /dev/null @@ -1,194 +0,0 @@ -/* Copyright (C) 1991, 1994, 1997-1998, 2000, 2003-2020 Free Software - Foundation, Inc. - - NOTE: The canonical source of this file is maintained with the GNU C - Library. Bugs can be reported to bug-glibc@prep.ai.mit.edu. - - This program is free software: you can redistribute it and/or modify it - under the terms of the GNU General Public License as published by the - Free Software Foundation; either version 3 of the License, or any - later version. - - This program is distributed in the hope that it will be useful, - but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see <https://www.gnu.org/licenses/>. */ - -#include <config.h> - -/* Specification. */ -#include <stdlib.h> - -#include <stddef.h> - -/* Include errno.h *after* sys/types.h to work around header problems - on AIX 3.2.5. */ -#include <errno.h> -#ifndef __set_errno -# define __set_errno(ev) ((errno) = (ev)) -#endif - -#include <string.h> -#include <unistd.h> - -#if defined _WIN32 && ! defined __CYGWIN__ -# define WIN32_LEAN_AND_MEAN -# include <windows.h> -#endif - -#if _LIBC -# if HAVE_GNU_LD -# define environ __environ -# else -extern char **environ; -# endif -#endif - -#if _LIBC -/* This lock protects against simultaneous modifications of 'environ'. */ -# include <bits/libc-lock.h> -__libc_lock_define_initialized (static, envlock) -# define LOCK __libc_lock_lock (envlock) -# define UNLOCK __libc_lock_unlock (envlock) -#else -# define LOCK -# define UNLOCK -#endif - -static int -_unsetenv (const char *name) -{ - size_t len; -#if !HAVE_DECL__PUTENV - char **ep; -#endif - - if (name == NULL || *name == '\0' || strchr (name, '=') != NULL) - { - __set_errno (EINVAL); - return -1; - } - - len = strlen (name); - -#if HAVE_DECL__PUTENV - { - int putenv_result, putenv_errno; - char *name_ = malloc (len + 2); - memcpy (name_, name, len); - name_[len] = '='; - name_[len + 1] = 0; - putenv_result = _putenv (name_); - putenv_errno = errno; - free (name_); - __set_errno (putenv_errno); - return putenv_result; - } -#else - - LOCK; - - ep = environ; - while (*ep != NULL) - if (!strncmp (*ep, name, len) && (*ep)[len] == '=') - { - /* Found it. Remove this pointer by moving later ones back. */ - char **dp = ep; - - do - dp[0] = dp[1]; - while (*dp++); - /* Continue the loop in case NAME appears again. */ - } - else - ++ep; - - UNLOCK; - - return 0; -#endif -} - - -/* Put STRING, which is of the form "NAME=VALUE", in the environment. - If STRING contains no '=', then remove STRING from the environment. */ -int -putenv (char *string) -{ - const char *name_end = strchr (string, '='); - char **ep; - - if (name_end == NULL) - { - /* Remove the variable from the environment. */ - return _unsetenv (string); - } - -#if HAVE_DECL__PUTENV - /* Rely on _putenv to allocate the new environment. If other - parts of the application use _putenv, the !HAVE_DECL__PUTENV code - would fight over who owns the environ vector, causing a crash. */ - if (name_end[1]) - return _putenv (string); - else - { - /* _putenv ("NAME=") unsets NAME, so invoke _putenv ("NAME= ") - to allocate the environ vector and then replace the new - entry with "NAME=". */ - int putenv_result, putenv_errno; - char *name_x = malloc (name_end - string + sizeof "= "); - if (!name_x) - return -1; - memcpy (name_x, string, name_end - string + 1); - name_x[name_end - string + 1] = ' '; - name_x[name_end - string + 2] = 0; - putenv_result = _putenv (name_x); - putenv_errno = errno; - for (ep = environ; *ep; ep++) - if (strcmp (*ep, name_x) == 0) - { - *ep = string; - break; - } -# if defined _WIN32 && ! defined __CYGWIN__ - if (putenv_result == 0) - { - /* _putenv propagated "NAME= " into the subprocess environment; - fix that by calling SetEnvironmentVariable directly. */ - name_x[name_end - string] = 0; - putenv_result = SetEnvironmentVariable (name_x, "") ? 0 : -1; - putenv_errno = ENOMEM; /* ENOMEM is the only way to fail. */ - } -# endif - free (name_x); - __set_errno (putenv_errno); - return putenv_result; - } -#else - for (ep = environ; *ep; ep++) - if (strncmp (*ep, string, name_end - string) == 0 - && (*ep)[name_end - string] == '=') - break; - - if (*ep) - *ep = string; - else - { - static char **last_environ = NULL; - size_t size = ep - environ; - char **new_environ = malloc ((size + 2) * sizeof *new_environ); - if (! new_environ) - return -1; - new_environ[0] = string; - memcpy (new_environ + 1, environ, (size + 1) * sizeof *new_environ); - free (last_environ); - last_environ = new_environ; - environ = new_environ; - } - - return 0; -#endif -} diff --git a/lib/regex.c b/lib/regex.c index 6bdd77f50b2..88173bb1052 100644 --- a/lib/regex.c +++ b/lib/regex.c @@ -17,6 +17,8 @@ License along with the GNU C Library; if not, see <https://www.gnu.org/licenses/>. */ +#define __STDC_WANT_IEC_60559_BFP_EXT__ + #ifndef _LIBC # include <libc-config.h> diff --git a/lib/regex_internal.h b/lib/regex_internal.h index 5c9cbf3b4fe..f6ebfb003e8 100644 --- a/lib/regex_internal.h +++ b/lib/regex_internal.h @@ -141,6 +141,24 @@ #ifndef SSIZE_MAX # define SSIZE_MAX ((ssize_t) (SIZE_MAX / 2)) #endif +#ifndef ULONG_WIDTH +# define ULONG_WIDTH REGEX_UINTEGER_WIDTH (ULONG_MAX) +/* The number of usable bits in an unsigned integer type with maximum + value MAX, as an int expression suitable in #if. Cover all known + practical hosts. This implementation exploits the fact that MAX is + 1 less than a power of 2, and merely counts the number of 1 bits in + MAX; "COBn" means "count the number of 1 bits in the low-order n bits". */ +# define REGEX_UINTEGER_WIDTH(max) REGEX_COB128 (max) +# define REGEX_COB128(n) (REGEX_COB64 ((n) >> 31 >> 31 >> 2) + REGEX_COB64 (n)) +# define REGEX_COB64(n) (REGEX_COB32 ((n) >> 31 >> 1) + REGEX_COB32 (n)) +# define REGEX_COB32(n) (REGEX_COB16 ((n) >> 16) + REGEX_COB16 (n)) +# define REGEX_COB16(n) (REGEX_COB8 ((n) >> 8) + REGEX_COB8 (n)) +# define REGEX_COB8(n) (REGEX_COB4 ((n) >> 4) + REGEX_COB4 (n)) +# define REGEX_COB4(n) (!!((n) & 8) + !!((n) & 4) + !!((n) & 2) + ((n) & 1)) +# if ULONG_MAX / 2 + 1 != 1ul << (ULONG_WIDTH - 1) +# error "ULONG_MAX out of range" +# endif +#endif /* The type of indexes into strings. This is signed, not size_t, since the API requires indexes to fit in regoff_t anyway, and using @@ -164,36 +182,8 @@ typedef __re_size_t re_hashval_t; typedef unsigned long int bitset_word_t; /* All bits set in a bitset_word_t. */ #define BITSET_WORD_MAX ULONG_MAX - -/* Number of bits in a bitset_word_t. For portability to hosts with - padding bits, do not use '(sizeof (bitset_word_t) * CHAR_BIT)'; - instead, deduce it directly from BITSET_WORD_MAX. Avoid - greater-than-32-bit integers and unconditional shifts by more than - 31 bits, as they're not portable. */ -#if BITSET_WORD_MAX == 0xffffffffUL -# define BITSET_WORD_BITS 32 -#elif BITSET_WORD_MAX >> 31 >> 4 == 1 -# define BITSET_WORD_BITS 36 -#elif BITSET_WORD_MAX >> 31 >> 16 == 1 -# define BITSET_WORD_BITS 48 -#elif BITSET_WORD_MAX >> 31 >> 28 == 1 -# define BITSET_WORD_BITS 60 -#elif BITSET_WORD_MAX >> 31 >> 31 >> 1 == 1 -# define BITSET_WORD_BITS 64 -#elif BITSET_WORD_MAX >> 31 >> 31 >> 9 == 1 -# define BITSET_WORD_BITS 72 -#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 3 == 1 -# define BITSET_WORD_BITS 128 -#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 7 == 1 -# define BITSET_WORD_BITS 256 -#elif BITSET_WORD_MAX >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 31 >> 7 > 1 -# define BITSET_WORD_BITS 257 /* any value > SBC_MAX will do here */ -# if BITSET_WORD_BITS <= SBC_MAX -# error "Invalid SBC_MAX" -# endif -#else -# error "Add case for new bitset_word_t size" -#endif +/* Number of bits in a bitset_word_t. */ +#define BITSET_WORD_BITS ULONG_WIDTH /* Number of bitset_word_t values in a bitset_t. */ #define BITSET_WORDS ((SBC_MAX + BITSET_WORD_BITS - 1) / BITSET_WORD_BITS) @@ -601,9 +591,8 @@ struct re_backref_cache_entry Idx str_idx; Idx subexp_from; Idx subexp_to; + bitset_word_t eps_reachable_subexps_map; char more; - char unused; - unsigned short int eps_reachable_subexps_map; }; typedef struct diff --git a/lib/sha1.c b/lib/sha1.c index 68e74ff3f98..bacf29c4051 100644 --- a/lib/sha1.c +++ b/lib/sha1.c @@ -1,8 +1,7 @@ /* sha1.c - Functions to compute SHA1 message digest of files or memory blocks according to the NIST specification FIPS-180-1. - Copyright (C) 2000-2001, 2003-2006, 2008-2020 Free Software - Foundation, Inc. + Copyright (C) 2000-2001, 2003-2006, 2008-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the diff --git a/lib/sha1.h b/lib/sha1.h index 2c9c2d4a5e2..b76788487c3 100644 --- a/lib/sha1.h +++ b/lib/sha1.h @@ -71,20 +71,21 @@ extern void sha1_process_bytes (const void *buffer, size_t len, in first 20 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha1_finish_ctx (struct sha1_ctx *ctx, void *resbuf); +extern void *sha1_finish_ctx (struct sha1_ctx *ctx, void *restrict resbuf); /* Put result from CTX in first 20 bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha1_read_ctx (const struct sha1_ctx *ctx, void *resbuf); +extern void *sha1_read_ctx (const struct sha1_ctx *ctx, void *restrict resbuf); /* Compute SHA1 message digest for LEN bytes beginning at BUFFER. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha1_buffer (const char *buffer, size_t len, void *resblock); +extern void *sha1_buffer (const char *buffer, size_t len, + void *restrict resblock); # endif /* Compute SHA1 message digest for bytes read from STREAM. diff --git a/lib/sha256.h b/lib/sha256.h index 1bc61d437c9..750d78a2696 100644 --- a/lib/sha256.h +++ b/lib/sha256.h @@ -70,23 +70,27 @@ extern void sha256_process_bytes (const void *buffer, size_t len, in first 32 (28) bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha256_finish_ctx (struct sha256_ctx *ctx, void *resbuf); -extern void *sha224_finish_ctx (struct sha256_ctx *ctx, void *resbuf); +extern void *sha256_finish_ctx (struct sha256_ctx *ctx, void *restrict resbuf); +extern void *sha224_finish_ctx (struct sha256_ctx *ctx, void *restrict resbuf); /* Put result from CTX in first 32 (28) bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha256_read_ctx (const struct sha256_ctx *ctx, void *resbuf); -extern void *sha224_read_ctx (const struct sha256_ctx *ctx, void *resbuf); +extern void *sha256_read_ctx (const struct sha256_ctx *ctx, + void *restrict resbuf); +extern void *sha224_read_ctx (const struct sha256_ctx *ctx, + void *restrict resbuf); -/* Compute SHA256 (SHA224) message digest for LEN bytes beginning at BUFFER. The - result is always in little endian byte order, so that a byte-wise +/* Compute SHA256 (SHA224) message digest for LEN bytes beginning at BUFFER. + The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha256_buffer (const char *buffer, size_t len, void *resblock); -extern void *sha224_buffer (const char *buffer, size_t len, void *resblock); +extern void *sha256_buffer (const char *buffer, size_t len, + void *restrict resblock); +extern void *sha224_buffer (const char *buffer, size_t len, + void *restrict resblock); # endif /* Compute SHA256 (SHA224) message digest for bytes read from STREAM. diff --git a/lib/sha512.h b/lib/sha512.h index aaf35a5f7d8..21c2f580147 100644 --- a/lib/sha512.h +++ b/lib/sha512.h @@ -70,8 +70,8 @@ extern void sha512_process_bytes (const void *buffer, size_t len, in first 64 (48) bytes following RESBUF. The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha512_finish_ctx (struct sha512_ctx *ctx, void *resbuf); -extern void *sha384_finish_ctx (struct sha512_ctx *ctx, void *resbuf); +extern void *sha512_finish_ctx (struct sha512_ctx *ctx, void *restrict resbuf); +extern void *sha384_finish_ctx (struct sha512_ctx *ctx, void *restrict resbuf); /* Put result from CTX in first 64 (48) bytes following RESBUF. The result is @@ -80,16 +80,20 @@ extern void *sha384_finish_ctx (struct sha512_ctx *ctx, void *resbuf); IMPORTANT: On some systems it is required that RESBUF is correctly aligned for a 32 bits value. */ -extern void *sha512_read_ctx (const struct sha512_ctx *ctx, void *resbuf); -extern void *sha384_read_ctx (const struct sha512_ctx *ctx, void *resbuf); +extern void *sha512_read_ctx (const struct sha512_ctx *ctx, + void *restrict resbuf); +extern void *sha384_read_ctx (const struct sha512_ctx *ctx, + void *restrict resbuf); -/* Compute SHA512 (SHA384) message digest for LEN bytes beginning at BUFFER. The - result is always in little endian byte order, so that a byte-wise +/* Compute SHA512 (SHA384) message digest for LEN bytes beginning at BUFFER. + The result is always in little endian byte order, so that a byte-wise output yields to the wanted ASCII representation of the message digest. */ -extern void *sha512_buffer (const char *buffer, size_t len, void *resblock); -extern void *sha384_buffer (const char *buffer, size_t len, void *resblock); +extern void *sha512_buffer (const char *buffer, size_t len, + void *restrict resblock); +extern void *sha384_buffer (const char *buffer, size_t len, + void *restrict resblock); # endif /* Compute SHA512 (SHA384) message digest for bytes read from STREAM. diff --git a/lib/sig2str.c b/lib/sig2str.c index 47c6cfcf95e..905daea2f20 100644 --- a/lib/sig2str.c +++ b/lib/sig2str.c @@ -1,7 +1,6 @@ /* sig2str.c -- convert between signal names and numbers - Copyright (C) 2002, 2004, 2006, 2009-2020 Free Software Foundation, - Inc. + Copyright (C) 2002, 2004, 2006, 2009-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/signal.in.h b/lib/signal.in.h index 42e1897f1ea..c94b053d6af 100644 --- a/lib/signal.in.h +++ b/lib/signal.in.h @@ -133,16 +133,24 @@ typedef void (*sighandler_t) (int); # define pthread_sigmask rpl_pthread_sigmask # endif _GL_FUNCDECL_RPL (pthread_sigmask, int, - (int how, const sigset_t *new_mask, sigset_t *old_mask)); + (int how, + const sigset_t *restrict new_mask, + sigset_t *restrict old_mask)); _GL_CXXALIAS_RPL (pthread_sigmask, int, - (int how, const sigset_t *new_mask, sigset_t *old_mask)); + (int how, + const sigset_t *restrict new_mask, + sigset_t *restrict old_mask)); # else # if !(@HAVE_PTHREAD_SIGMASK@ || defined pthread_sigmask) _GL_FUNCDECL_SYS (pthread_sigmask, int, - (int how, const sigset_t *new_mask, sigset_t *old_mask)); + (int how, + const sigset_t *restrict new_mask, + sigset_t *restrict old_mask)); # endif _GL_CXXALIAS_SYS (pthread_sigmask, int, - (int how, const sigset_t *new_mask, sigset_t *old_mask)); + (int how, + const sigset_t *restrict new_mask, + sigset_t *restrict old_mask)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (pthread_sigmask); @@ -295,10 +303,14 @@ _GL_CXXALIASWARN (sigpending); # define SIG_SETMASK 1 /* blocked_set = *set; */ # define SIG_UNBLOCK 2 /* blocked_set = blocked_set & ~*set; */ _GL_FUNCDECL_SYS (sigprocmask, int, - (int operation, const sigset_t *set, sigset_t *old_set)); + (int operation, + const sigset_t *restrict set, + sigset_t *restrict old_set)); # endif _GL_CXXALIAS_SYS (sigprocmask, int, - (int operation, const sigset_t *set, sigset_t *old_set)); + (int operation, + const sigset_t *restrict set, + sigset_t *restrict old_set)); _GL_CXXALIASWARN (sigprocmask); /* Install the handler FUNC for signal SIG, and return the previous @@ -322,6 +334,12 @@ _GL_FUNCDECL_RPL (signal, _gl_function_taking_int_returning_void_t, _GL_CXXALIAS_RPL (signal, _gl_function_taking_int_returning_void_t, (int sig, _gl_function_taking_int_returning_void_t func)); # else +/* On OpenBSD, the declaration of 'signal' may not be present at this point, + because it occurs in <sys/signal.h>, not <signal.h> directly. */ +# if defined __OpenBSD__ +_GL_FUNCDECL_SYS (signal, _gl_function_taking_int_returning_void_t, + (int sig, _gl_function_taking_int_returning_void_t func)); +# endif _GL_CXXALIAS_SYS (signal, _gl_function_taking_int_returning_void_t, (int sig, _gl_function_taking_int_returning_void_t func)); # endif diff --git a/lib/stdalign.in.h b/lib/stdalign.in.h index 2f53411e16c..cd786bed2cd 100644 --- a/lib/stdalign.in.h +++ b/lib/stdalign.in.h @@ -102,7 +102,7 @@ # define _Alignas(a) alignas (a) # elif ((defined __APPLE__ && defined __MACH__ \ ? 4 < __GNUC__ + (1 <= __GNUC_MINOR__) \ - : __GNUC__) \ + : __GNUC__ && !defined __ibmxl__) \ || (__ia64 && (61200 <= __HP_cc || 61200 <= __HP_aCC)) \ || __ICC || 0x590 <= __SUNPRO_C || 0x0600 <= __xlC__) # define _Alignas(a) __attribute__ ((__aligned__ (a))) diff --git a/lib/stddef.in.h b/lib/stddef.in.h index e146063c026..2e50a1f01e8 100644 --- a/lib/stddef.in.h +++ b/lib/stddef.in.h @@ -83,20 +83,26 @@ /* Some platforms lack max_align_t. The check for _GCC_MAX_ALIGN_T is a hack in case the configure-time test was done with g++ even though - we are currently compiling with gcc. */ -#if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) -# if !GNULIB_defined_max_align_t + we are currently compiling with gcc. + On MSVC, max_align_t is defined only in C++ mode, after <cstddef> was + included. Its definition is good since it has an alignment of 8 (on x86 + and x86_64). */ +#if defined _MSC_VER && defined __cplusplus +# include <cstddef> +#else +# if ! (@HAVE_MAX_ALIGN_T@ || defined _GCC_MAX_ALIGN_T) +# if !GNULIB_defined_max_align_t /* On the x86, the maximum storage alignment of double, long, etc. is 4, but GCC's C11 ABI for x86 says that max_align_t has an alignment of 8, and the C11 standard allows this. Work around this problem by using __alignof__ (which returns 8 for double) rather than _Alignof (which returns 4), and align each union member accordingly. */ -# ifdef __GNUC__ -# define _GL_STDDEF_ALIGNAS(type) \ - __attribute__ ((__aligned__ (__alignof__ (type)))) -# else -# define _GL_STDDEF_ALIGNAS(type) /* */ -# endif +# ifdef __GNUC__ +# define _GL_STDDEF_ALIGNAS(type) \ + __attribute__ ((__aligned__ (__alignof__ (type)))) +# else +# define _GL_STDDEF_ALIGNAS(type) /* */ +# endif typedef union { char *__p _GL_STDDEF_ALIGNAS (char *); @@ -104,8 +110,9 @@ typedef union long double __ld _GL_STDDEF_ALIGNAS (long double); long int __i _GL_STDDEF_ALIGNAS (long int); } rpl_max_align_t; -# define max_align_t rpl_max_align_t -# define GNULIB_defined_max_align_t 1 +# define max_align_t rpl_max_align_t +# define GNULIB_defined_max_align_t 1 +# endif # endif #endif diff --git a/lib/stdint.in.h b/lib/stdint.in.h index a83bc45c79c..994c0c777c0 100644 --- a/lib/stdint.in.h +++ b/lib/stdint.in.h @@ -188,7 +188,7 @@ typedef long int gl_int64_t; typedef __int64 gl_int64_t; # define int64_t gl_int64_t # define GL_INT64_T -# elif @HAVE_LONG_LONG_INT@ +# else # undef int64_t typedef long long int gl_int64_t; # define int64_t gl_int64_t @@ -209,7 +209,7 @@ typedef unsigned long int gl_uint64_t; typedef unsigned __int64 gl_uint64_t; # define uint64_t gl_uint64_t # define GL_UINT64_T -# elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# else # undef uint64_t typedef unsigned long long int gl_uint64_t; # define uint64_t gl_uint64_t @@ -333,7 +333,7 @@ typedef unsigned long int gl_uintptr_t; # ifndef INTMAX_MAX # undef INTMAX_C # undef intmax_t -# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# if LONG_MAX >> 30 == 1 typedef long long int gl_intmax_t; # define intmax_t gl_intmax_t # elif defined GL_INT64_T @@ -347,7 +347,7 @@ typedef long int gl_intmax_t; # ifndef UINTMAX_MAX # undef UINTMAX_C # undef uintmax_t -# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# if ULONG_MAX >> 31 == 1 typedef unsigned long long int gl_uintmax_t; # define uintmax_t gl_uintmax_t # elif defined GL_UINT64_T @@ -647,21 +647,21 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) # define INT64_C(x) x##L # elif defined _MSC_VER # define INT64_C(x) x##i64 -# elif @HAVE_LONG_LONG_INT@ +# else # define INT64_C(x) x##LL # endif # if ULONG_MAX >> 31 >> 31 >> 1 == 1 # define UINT64_C(x) x##UL # elif defined _MSC_VER # define UINT64_C(x) x##ui64 -# elif @HAVE_UNSIGNED_LONG_LONG_INT@ +# else # define UINT64_C(x) x##ULL # endif /* 7.18.4.2. Macros for greatest-width integer constants */ # ifndef INTMAX_C -# if @HAVE_LONG_LONG_INT@ && LONG_MAX >> 30 == 1 +# if LONG_MAX >> 30 == 1 # define INTMAX_C(x) x##LL # elif defined GL_INT64_T # define INTMAX_C(x) INT64_C(x) @@ -671,7 +671,7 @@ typedef int _verify_intmax_size[sizeof (intmax_t) == sizeof (uintmax_t) # endif # ifndef UINTMAX_C -# if @HAVE_UNSIGNED_LONG_LONG_INT@ && ULONG_MAX >> 31 == 1 +# if ULONG_MAX >> 31 == 1 # define UINTMAX_C(x) x##ULL # elif defined GL_UINT64_T # define UINTMAX_C(x) UINT64_C(x) diff --git a/lib/stdio.in.h b/lib/stdio.in.h index 6dc526eaab0..6c338dd6c0b 100644 --- a/lib/stdio.in.h +++ b/lib/stdio.in.h @@ -62,10 +62,12 @@ We enable _GL_ATTRIBUTE_FORMAT only if these are supported too, because gnulib and libintl do '#define printf __printf__' when they override the 'printf' function. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) -# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) -#else -# define _GL_ATTRIBUTE_FORMAT(spec) /* empty */ +#ifndef _GL_ATTRIBUTE_FORMAT +# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) +# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) +# else +# define _GL_ATTRIBUTE_FORMAT(spec) /* empty */ +# endif #endif /* _GL_ATTRIBUTE_FORMAT_PRINTF @@ -171,17 +173,17 @@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define dprintf rpl_dprintf # endif -_GL_FUNCDECL_RPL (dprintf, int, (int fd, const char *format, ...) +_GL_FUNCDECL_RPL (dprintf, int, (int fd, const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) _GL_ARG_NONNULL ((2))); -_GL_CXXALIAS_RPL (dprintf, int, (int fd, const char *format, ...)); +_GL_CXXALIAS_RPL (dprintf, int, (int fd, const char *restrict format, ...)); # else # if !@HAVE_DPRINTF@ -_GL_FUNCDECL_SYS (dprintf, int, (int fd, const char *format, ...) +_GL_FUNCDECL_SYS (dprintf, int, (int fd, const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) _GL_ARG_NONNULL ((2))); # endif -_GL_CXXALIAS_SYS (dprintf, int, (int fd, const char *format, ...)); +_GL_CXXALIAS_SYS (dprintf, int, (int fd, const char *restrict format, ...)); # endif _GL_CXXALIASWARN (dprintf); #elif defined GNULIB_POSIXCHECK @@ -281,11 +283,14 @@ _GL_CXXALIASWARN (fgetc); # undef fgets # define fgets rpl_fgets # endif -_GL_FUNCDECL_RPL (fgets, char *, (char *s, int n, FILE *stream) - _GL_ARG_NONNULL ((1, 3))); -_GL_CXXALIAS_RPL (fgets, char *, (char *s, int n, FILE *stream)); +_GL_FUNCDECL_RPL (fgets, char *, + (char *restrict s, int n, FILE *restrict stream) + _GL_ARG_NONNULL ((1, 3))); +_GL_CXXALIAS_RPL (fgets, char *, + (char *restrict s, int n, FILE *restrict stream)); # else -_GL_CXXALIAS_SYS (fgets, char *, (char *s, int n, FILE *stream)); +_GL_CXXALIAS_SYS (fgets, char *, + (char *restrict s, int n, FILE *restrict stream)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fgets); @@ -298,11 +303,14 @@ _GL_CXXALIASWARN (fgets); # undef fopen # define fopen rpl_fopen # endif -_GL_FUNCDECL_RPL (fopen, FILE *, (const char *filename, const char *mode) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (fopen, FILE *, (const char *filename, const char *mode)); +_GL_FUNCDECL_RPL (fopen, FILE *, + (const char *restrict filename, const char *restrict mode) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (fopen, FILE *, + (const char *restrict filename, const char *restrict mode)); # else -_GL_CXXALIAS_SYS (fopen, FILE *, (const char *filename, const char *mode)); +_GL_CXXALIAS_SYS (fopen, FILE *, + (const char *restrict filename, const char *restrict mode)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fopen); @@ -322,17 +330,21 @@ _GL_WARN_ON_USE (fopen, "fopen on native Windows platforms is not POSIX complian # endif # define GNULIB_overrides_fprintf 1 # if @GNULIB_FPRINTF_POSIX@ || @GNULIB_VFPRINTF_POSIX@ -_GL_FUNCDECL_RPL (fprintf, int, (FILE *fp, const char *format, ...) - _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) - _GL_ARG_NONNULL ((1, 2))); +_GL_FUNCDECL_RPL (fprintf, int, + (FILE *restrict fp, const char *restrict format, ...) + _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) + _GL_ARG_NONNULL ((1, 2))); # else -_GL_FUNCDECL_RPL (fprintf, int, (FILE *fp, const char *format, ...) - _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (2, 3) - _GL_ARG_NONNULL ((1, 2))); +_GL_FUNCDECL_RPL (fprintf, int, + (FILE *restrict fp, const char *restrict format, ...) + _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (2, 3) + _GL_ARG_NONNULL ((1, 2))); # endif -_GL_CXXALIAS_RPL (fprintf, int, (FILE *fp, const char *format, ...)); +_GL_CXXALIAS_RPL (fprintf, int, + (FILE *restrict fp, const char *restrict format, ...)); # else -_GL_CXXALIAS_SYS (fprintf, int, (FILE *fp, const char *format, ...)); +_GL_CXXALIAS_SYS (fprintf, int, + (FILE *restrict fp, const char *restrict format, ...)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fprintf); @@ -398,11 +410,14 @@ _GL_CXXALIASWARN (fputc); # undef fputs # define fputs rpl_fputs # endif -_GL_FUNCDECL_RPL (fputs, int, (const char *string, FILE *stream) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (fputs, int, (const char *string, FILE *stream)); +_GL_FUNCDECL_RPL (fputs, int, + (const char *restrict string, FILE *restrict stream) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (fputs, int, + (const char *restrict string, FILE *restrict stream)); # else -_GL_CXXALIAS_SYS (fputs, int, (const char *string, FILE *stream)); +_GL_CXXALIAS_SYS (fputs, int, + (const char *restrict string, FILE *restrict stream)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fputs); @@ -415,11 +430,17 @@ _GL_CXXALIASWARN (fputs); # undef fread # define fread rpl_fread # endif -_GL_FUNCDECL_RPL (fread, size_t, (void *ptr, size_t s, size_t n, FILE *stream) - _GL_ARG_NONNULL ((4))); -_GL_CXXALIAS_RPL (fread, size_t, (void *ptr, size_t s, size_t n, FILE *stream)); +_GL_FUNCDECL_RPL (fread, size_t, + (void *restrict ptr, size_t s, size_t n, + FILE *restrict stream) + _GL_ARG_NONNULL ((4))); +_GL_CXXALIAS_RPL (fread, size_t, + (void *restrict ptr, size_t s, size_t n, + FILE *restrict stream)); # else -_GL_CXXALIAS_SYS (fread, size_t, (void *ptr, size_t s, size_t n, FILE *stream)); +_GL_CXXALIAS_SYS (fread, size_t, + (void *restrict ptr, size_t s, size_t n, + FILE *restrict stream)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fread); @@ -433,13 +454,16 @@ _GL_CXXALIASWARN (fread); # define freopen rpl_freopen # endif _GL_FUNCDECL_RPL (freopen, FILE *, - (const char *filename, const char *mode, FILE *stream) + (const char *restrict filename, const char *restrict mode, + FILE *restrict stream) _GL_ARG_NONNULL ((2, 3))); _GL_CXXALIAS_RPL (freopen, FILE *, - (const char *filename, const char *mode, FILE *stream)); + (const char *restrict filename, const char *restrict mode, + FILE *restrict stream)); # else _GL_CXXALIAS_SYS (freopen, FILE *, - (const char *filename, const char *mode, FILE *stream)); + (const char *restrict filename, const char *restrict mode, + FILE *restrict stream)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (freopen); @@ -458,12 +482,15 @@ _GL_WARN_ON_USE (freopen, # undef fscanf # define fscanf rpl_fscanf # endif -_GL_FUNCDECL_RPL (fscanf, int, (FILE *stream, const char *format, ...) - _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (2, 3) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (fscanf, int, (FILE *stream, const char *format, ...)); +_GL_FUNCDECL_RPL (fscanf, int, + (FILE *restrict stream, const char *restrict format, ...) + _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (2, 3) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (fscanf, int, + (FILE *restrict stream, const char *restrict format, ...)); # else -_GL_CXXALIAS_SYS (fscanf, int, (FILE *stream, const char *format, ...)); +_GL_CXXALIAS_SYS (fscanf, int, + (FILE *restrict stream, const char *restrict format, ...)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (fscanf); @@ -634,13 +661,16 @@ _GL_WARN_ON_USE (ftell, "ftell cannot handle files larger than 4 GB " # define fwrite rpl_fwrite # endif _GL_FUNCDECL_RPL (fwrite, size_t, - (const void *ptr, size_t s, size_t n, FILE *stream) + (const void *restrict ptr, size_t s, size_t n, + FILE *restrict stream) _GL_ARG_NONNULL ((1, 4))); _GL_CXXALIAS_RPL (fwrite, size_t, - (const void *ptr, size_t s, size_t n, FILE *stream)); + (const void *restrict ptr, size_t s, size_t n, + FILE *restrict stream)); # else _GL_CXXALIAS_SYS (fwrite, size_t, - (const void *ptr, size_t s, size_t n, FILE *stream)); + (const void *restrict ptr, size_t s, size_t n, + FILE *restrict stream)); /* Work around bug 11959 when fortifying glibc 2.4 through 2.15 <https://sourceware.org/bugzilla/show_bug.cgi?id=11959>, @@ -715,22 +745,26 @@ _GL_CXXALIASWARN (getchar); # define getdelim rpl_getdelim # endif _GL_FUNCDECL_RPL (getdelim, ssize_t, - (char **lineptr, size_t *linesize, int delimiter, - FILE *stream) + (char **restrict lineptr, size_t *restrict linesize, + int delimiter, + FILE *restrict stream) _GL_ARG_NONNULL ((1, 2, 4))); _GL_CXXALIAS_RPL (getdelim, ssize_t, - (char **lineptr, size_t *linesize, int delimiter, - FILE *stream)); + (char **restrict lineptr, size_t *restrict linesize, + int delimiter, + FILE *restrict stream)); # else # if !@HAVE_DECL_GETDELIM@ _GL_FUNCDECL_SYS (getdelim, ssize_t, - (char **lineptr, size_t *linesize, int delimiter, - FILE *stream) + (char **restrict lineptr, size_t *restrict linesize, + int delimiter, + FILE *restrict stream) _GL_ARG_NONNULL ((1, 2, 4))); # endif _GL_CXXALIAS_SYS (getdelim, ssize_t, - (char **lineptr, size_t *linesize, int delimiter, - FILE *stream)); + (char **restrict lineptr, size_t *restrict linesize, + int delimiter, + FILE *restrict stream)); # endif _GL_CXXALIASWARN (getdelim); #elif defined GNULIB_POSIXCHECK @@ -754,18 +788,22 @@ _GL_WARN_ON_USE (getdelim, "getdelim is unportable - " # define getline rpl_getline # endif _GL_FUNCDECL_RPL (getline, ssize_t, - (char **lineptr, size_t *linesize, FILE *stream) + (char **restrict lineptr, size_t *restrict linesize, + FILE *restrict stream) _GL_ARG_NONNULL ((1, 2, 3))); _GL_CXXALIAS_RPL (getline, ssize_t, - (char **lineptr, size_t *linesize, FILE *stream)); + (char **restrict lineptr, size_t *restrict linesize, + FILE *restrict stream)); # else # if !@HAVE_DECL_GETLINE@ _GL_FUNCDECL_SYS (getline, ssize_t, - (char **lineptr, size_t *linesize, FILE *stream) + (char **restrict lineptr, size_t *restrict linesize, + FILE *restrict stream) _GL_ARG_NONNULL ((1, 2, 3))); # endif _GL_CXXALIAS_SYS (getline, ssize_t, - (char **lineptr, size_t *linesize, FILE *stream)); + (char **restrict lineptr, size_t *restrict linesize, + FILE *restrict stream)); # endif # if @HAVE_DECL_GETLINE@ _GL_CXXALIASWARN (getline); @@ -909,14 +947,14 @@ _GL_WARN_ON_USE (popen, "popen is buggy on some platforms - " # endif # if @GNULIB_PRINTF_POSIX@ || @GNULIB_VFPRINTF_POSIX@ _GL_FUNCDECL_RPL_1 (__printf__, int, - (const char *format, ...) + (const char *restrict format, ...) __asm__ (@ASM_SYMBOL_PREFIX@ _GL_STDIO_MACROEXPAND_AND_STRINGIZE(rpl_printf)) _GL_ATTRIBUTE_FORMAT_PRINTF (1, 2) _GL_ARG_NONNULL ((1))); # else _GL_FUNCDECL_RPL_1 (__printf__, int, - (const char *format, ...) + (const char *restrict format, ...) __asm__ (@ASM_SYMBOL_PREFIX@ _GL_STDIO_MACROEXPAND_AND_STRINGIZE(rpl_printf)) _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (1, 2) @@ -928,14 +966,14 @@ _GL_CXXALIAS_RPL_1 (printf, __printf__, int, (const char *format, ...)); # define printf rpl_printf # endif _GL_FUNCDECL_RPL (printf, int, - (const char *format, ...) + (const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_PRINTF (1, 2) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (printf, int, (const char *format, ...)); +_GL_CXXALIAS_RPL (printf, int, (const char *restrict format, ...)); # endif # define GNULIB_overrides_printf 1 # else -_GL_CXXALIAS_SYS (printf, int, (const char *format, ...)); +_GL_CXXALIAS_SYS (printf, int, (const char *restrict format, ...)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (printf); @@ -1083,24 +1121,24 @@ _GL_WARN_ON_USE (renameat, "renameat is not portable - " # define scanf __scanf__ # endif _GL_FUNCDECL_RPL_1 (__scanf__, int, - (const char *format, ...) + (const char *restrict format, ...) __asm__ (@ASM_SYMBOL_PREFIX@ _GL_STDIO_MACROEXPAND_AND_STRINGIZE(rpl_scanf)) _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (1, 2) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL_1 (scanf, __scanf__, int, (const char *format, ...)); +_GL_CXXALIAS_RPL_1 (scanf, __scanf__, int, (const char *restrict format, ...)); # else # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef scanf # define scanf rpl_scanf # endif -_GL_FUNCDECL_RPL (scanf, int, (const char *format, ...) +_GL_FUNCDECL_RPL (scanf, int, (const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (1, 2) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (scanf, int, (const char *format, ...)); +_GL_CXXALIAS_RPL (scanf, int, (const char *restrict format, ...)); # endif # else -_GL_CXXALIAS_SYS (scanf, int, (const char *format, ...)); +_GL_CXXALIAS_SYS (scanf, int, (const char *restrict format, ...)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (scanf); @@ -1113,20 +1151,24 @@ _GL_CXXALIASWARN (scanf); # define snprintf rpl_snprintf # endif _GL_FUNCDECL_RPL (snprintf, int, - (char *str, size_t size, const char *format, ...) + (char *restrict str, size_t size, + const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_PRINTF (3, 4) _GL_ARG_NONNULL ((3))); _GL_CXXALIAS_RPL (snprintf, int, - (char *str, size_t size, const char *format, ...)); + (char *restrict str, size_t size, + const char *restrict format, ...)); # else # if !@HAVE_DECL_SNPRINTF@ _GL_FUNCDECL_SYS (snprintf, int, - (char *str, size_t size, const char *format, ...) + (char *restrict str, size_t size, + const char *restrict format, ...) _GL_ATTRIBUTE_FORMAT_PRINTF (3, 4) _GL_ARG_NONNULL ((3))); # endif _GL_CXXALIAS_SYS (snprintf, int, - (char *str, size_t size, const char *format, ...)); + (char *restrict str, size_t size, + const char *restrict format, ...)); # endif _GL_CXXALIASWARN (snprintf); #elif defined GNULIB_POSIXCHECK @@ -1151,12 +1193,15 @@ _GL_WARN_ON_USE (snprintf, "snprintf is unportable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define sprintf rpl_sprintf # endif -_GL_FUNCDECL_RPL (sprintf, int, (char *str, const char *format, ...) - _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (sprintf, int, (char *str, const char *format, ...)); +_GL_FUNCDECL_RPL (sprintf, int, + (char *restrict str, const char *restrict format, ...) + _GL_ATTRIBUTE_FORMAT_PRINTF (2, 3) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (sprintf, int, + (char *restrict str, const char *restrict format, ...)); # else -_GL_CXXALIAS_SYS (sprintf, int, (char *str, const char *format, ...)); +_GL_CXXALIAS_SYS (sprintf, int, + (char *restrict str, const char *restrict format, ...)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (sprintf); @@ -1244,22 +1289,27 @@ _GL_CXXALIASWARN (vasprintf); # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define vdprintf rpl_vdprintf # endif -_GL_FUNCDECL_RPL (vdprintf, int, (int fd, const char *format, va_list args) - _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) - _GL_ARG_NONNULL ((2))); -_GL_CXXALIAS_RPL (vdprintf, int, (int fd, const char *format, va_list args)); +_GL_FUNCDECL_RPL (vdprintf, int, + (int fd, const char *restrict format, va_list args) + _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_RPL (vdprintf, int, + (int fd, const char *restrict format, va_list args)); # else # if !@HAVE_VDPRINTF@ -_GL_FUNCDECL_SYS (vdprintf, int, (int fd, const char *format, va_list args) - _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) - _GL_ARG_NONNULL ((2))); +_GL_FUNCDECL_SYS (vdprintf, int, + (int fd, const char *restrict format, va_list args) + _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) + _GL_ARG_NONNULL ((2))); # endif /* Need to cast, because on Solaris, the third parameter will likely be __va_list args. */ _GL_CXXALIAS_SYS_CAST (vdprintf, int, - (int fd, const char *format, va_list args)); + (int fd, const char *restrict format, va_list args)); # endif +# if __GLIBC__ >= 2 _GL_CXXALIASWARN (vdprintf); +# endif #elif defined GNULIB_POSIXCHECK # undef vdprintf # if HAVE_RAW_DECL_VDPRINTF @@ -1276,21 +1326,28 @@ _GL_WARN_ON_USE (vdprintf, "vdprintf is unportable - " # endif # define GNULIB_overrides_vfprintf 1 # if @GNULIB_VFPRINTF_POSIX@ -_GL_FUNCDECL_RPL (vfprintf, int, (FILE *fp, const char *format, va_list args) - _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) - _GL_ARG_NONNULL ((1, 2))); +_GL_FUNCDECL_RPL (vfprintf, int, + (FILE *restrict fp, + const char *restrict format, va_list args) + _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) + _GL_ARG_NONNULL ((1, 2))); # else -_GL_FUNCDECL_RPL (vfprintf, int, (FILE *fp, const char *format, va_list args) - _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (2, 0) - _GL_ARG_NONNULL ((1, 2))); +_GL_FUNCDECL_RPL (vfprintf, int, + (FILE *restrict fp, + const char *restrict format, va_list args) + _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (2, 0) + _GL_ARG_NONNULL ((1, 2))); # endif -_GL_CXXALIAS_RPL (vfprintf, int, (FILE *fp, const char *format, va_list args)); +_GL_CXXALIAS_RPL (vfprintf, int, + (FILE *restrict fp, + const char *restrict format, va_list args)); # else /* Need to cast, because on Solaris, the third parameter is __va_list args and GCC's fixincludes did not change this to __gnuc_va_list. */ _GL_CXXALIAS_SYS_CAST (vfprintf, int, - (FILE *fp, const char *format, va_list args)); + (FILE *restrict fp, + const char *restrict format, va_list args)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (vfprintf); @@ -1313,14 +1370,17 @@ _GL_WARN_ON_USE (vfprintf, "vfprintf is not always POSIX compliant - " # define vfscanf rpl_vfscanf # endif _GL_FUNCDECL_RPL (vfscanf, int, - (FILE *stream, const char *format, va_list args) + (FILE *restrict stream, + const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (2, 0) _GL_ARG_NONNULL ((1, 2))); _GL_CXXALIAS_RPL (vfscanf, int, - (FILE *stream, const char *format, va_list args)); + (FILE *restrict stream, + const char *restrict format, va_list args)); # else _GL_CXXALIAS_SYS (vfscanf, int, - (FILE *stream, const char *format, va_list args)); + (FILE *restrict stream, + const char *restrict format, va_list args)); # endif _GL_CXXALIASWARN (vfscanf); #endif @@ -1333,20 +1393,21 @@ _GL_CXXALIASWARN (vfscanf); # endif # define GNULIB_overrides_vprintf 1 # if @GNULIB_VPRINTF_POSIX@ || @GNULIB_VFPRINTF_POSIX@ -_GL_FUNCDECL_RPL (vprintf, int, (const char *format, va_list args) +_GL_FUNCDECL_RPL (vprintf, int, (const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_PRINTF (1, 0) _GL_ARG_NONNULL ((1))); # else -_GL_FUNCDECL_RPL (vprintf, int, (const char *format, va_list args) +_GL_FUNCDECL_RPL (vprintf, int, (const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_PRINTF_SYSTEM (1, 0) _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_RPL (vprintf, int, (const char *format, va_list args)); +_GL_CXXALIAS_RPL (vprintf, int, (const char *restrict format, va_list args)); # else /* Need to cast, because on Solaris, the second parameter is __va_list args and GCC's fixincludes did not change this to __gnuc_va_list. */ -_GL_CXXALIAS_SYS_CAST (vprintf, int, (const char *format, va_list args)); +_GL_CXXALIAS_SYS_CAST (vprintf, int, + (const char *restrict format, va_list args)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (vprintf); @@ -1368,12 +1429,12 @@ _GL_WARN_ON_USE (vprintf, "vprintf is not always POSIX compliant - " # undef vscanf # define vscanf rpl_vscanf # endif -_GL_FUNCDECL_RPL (vscanf, int, (const char *format, va_list args) +_GL_FUNCDECL_RPL (vscanf, int, (const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_SCANF_SYSTEM (1, 0) _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (vscanf, int, (const char *format, va_list args)); +_GL_CXXALIAS_RPL (vscanf, int, (const char *restrict format, va_list args)); # else -_GL_CXXALIAS_SYS (vscanf, int, (const char *format, va_list args)); +_GL_CXXALIAS_SYS (vscanf, int, (const char *restrict format, va_list args)); # endif _GL_CXXALIASWARN (vscanf); #endif @@ -1384,20 +1445,24 @@ _GL_CXXALIASWARN (vscanf); # define vsnprintf rpl_vsnprintf # endif _GL_FUNCDECL_RPL (vsnprintf, int, - (char *str, size_t size, const char *format, va_list args) + (char *restrict str, size_t size, + const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_PRINTF (3, 0) _GL_ARG_NONNULL ((3))); _GL_CXXALIAS_RPL (vsnprintf, int, - (char *str, size_t size, const char *format, va_list args)); + (char *restrict str, size_t size, + const char *restrict format, va_list args)); # else # if !@HAVE_DECL_VSNPRINTF@ _GL_FUNCDECL_SYS (vsnprintf, int, - (char *str, size_t size, const char *format, va_list args) + (char *restrict str, size_t size, + const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_PRINTF (3, 0) _GL_ARG_NONNULL ((3))); # endif _GL_CXXALIAS_SYS (vsnprintf, int, - (char *str, size_t size, const char *format, va_list args)); + (char *restrict str, size_t size, + const char *restrict format, va_list args)); # endif _GL_CXXALIASWARN (vsnprintf); #elif defined GNULIB_POSIXCHECK @@ -1414,17 +1479,20 @@ _GL_WARN_ON_USE (vsnprintf, "vsnprintf is unportable - " # define vsprintf rpl_vsprintf # endif _GL_FUNCDECL_RPL (vsprintf, int, - (char *str, const char *format, va_list args) + (char *restrict str, + const char *restrict format, va_list args) _GL_ATTRIBUTE_FORMAT_PRINTF (2, 0) _GL_ARG_NONNULL ((1, 2))); _GL_CXXALIAS_RPL (vsprintf, int, - (char *str, const char *format, va_list args)); + (char *restrict str, + const char *restrict format, va_list args)); # else /* Need to cast, because on Solaris, the third parameter is __va_list args and GCC's fixincludes did not change this to __gnuc_va_list. */ _GL_CXXALIAS_SYS_CAST (vsprintf, int, - (char *str, const char *format, va_list args)); + (char *restrict str, + const char *restrict format, va_list args)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (vsprintf); diff --git a/lib/stdlib.in.h b/lib/stdlib.in.h index 1524277d799..59f9e6c71d1 100644 --- a/lib/stdlib.in.h +++ b/lib/stdlib.in.h @@ -1,7 +1,6 @@ /* A GNU-like <stdlib.h>. - Copyright (C) 1995, 2001-2004, 2006-2020 Free Software Foundation, - Inc. + Copyright (C) 1995, 2001-2004, 2006-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -102,10 +101,12 @@ struct random_data /* The __attribute__ feature is available in gcc versions 2.5 and later. The attribute __pure__ was added in gcc 2.96. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) -# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) -#else -# define _GL_ATTRIBUTE_PURE /* empty */ +#ifndef _GL_ATTRIBUTE_PURE +# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) +# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) +# else +# define _GL_ATTRIBUTE_PURE /* empty */ +# endif #endif /* The definition of _Noreturn is copied here. */ @@ -202,6 +203,10 @@ _GL_FUNCDECL_SYS (canonicalize_file_name, char *, (const char *name) # endif _GL_CXXALIAS_SYS (canonicalize_file_name, char *, (const char *name)); # endif +# ifndef GNULIB_defined_canonicalize_file_name +# define GNULIB_defined_canonicalize_file_name \ + (!@HAVE_CANONICALIZE_FILE_NAME@ || @REPLACE_CANONICALIZE_FILE_NAME@) +# endif _GL_CXXALIASWARN (canonicalize_file_name); #elif defined GNULIB_POSIXCHECK # undef canonicalize_file_name @@ -308,13 +313,17 @@ _GL_WARN_ON_USE (malloc, "malloc is not POSIX compliant everywhere - " # undef mbtowc # define mbtowc rpl_mbtowc # endif -_GL_FUNCDECL_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n)); -_GL_CXXALIAS_RPL (mbtowc, int, (wchar_t *pwc, const char *s, size_t n)); +_GL_FUNCDECL_RPL (mbtowc, int, + (wchar_t *restrict pwc, const char *restrict s, size_t n)); +_GL_CXXALIAS_RPL (mbtowc, int, + (wchar_t *restrict pwc, const char *restrict s, size_t n)); # else # if !@HAVE_MBTOWC@ -_GL_FUNCDECL_SYS (mbtowc, int, (wchar_t *pwc, const char *s, size_t n)); +_GL_FUNCDECL_SYS (mbtowc, int, + (wchar_t *restrict pwc, const char *restrict s, size_t n)); # endif -_GL_CXXALIAS_SYS (mbtowc, int, (wchar_t *pwc, const char *s, size_t n)); +_GL_CXXALIAS_SYS (mbtowc, int, + (wchar_t *restrict pwc, const char *restrict s, size_t n)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (mbtowc); @@ -517,6 +526,9 @@ _GL_FUNCDECL_SYS (ptsname_r, int, (int fd, char *buf, size_t len)); # endif _GL_CXXALIAS_SYS (ptsname_r, int, (int fd, char *buf, size_t len)); # endif +# ifndef GNULIB_defined_ptsname_r +# define GNULIB_defined_ptsname_r (!@HAVE_PTSNAME_R@ || @REPLACE_PTSNAME_R@) +# endif _GL_CXXALIASWARN (ptsname_r); #elif defined GNULIB_POSIXCHECK # undef ptsname_r @@ -600,7 +612,9 @@ _GL_CXXALIAS_RPL (random, long, (void)); # if !@HAVE_RANDOM@ _GL_FUNCDECL_SYS (random, long, (void)); # endif -_GL_CXXALIAS_SYS (random, long, (void)); +/* Need to cast, because on Haiku, the return type is + int. */ +_GL_CXXALIAS_SYS_CAST (random, long, (void)); # endif _GL_CXXALIASWARN (random); #elif defined GNULIB_POSIXCHECK @@ -767,9 +781,11 @@ _GL_FUNCDECL_SYS (initstate_r, int, struct random_data *rand_state) _GL_ARG_NONNULL ((2, 4))); # endif -_GL_CXXALIAS_SYS (initstate_r, int, - (unsigned int seed, char *buf, size_t buf_size, - struct random_data *rand_state)); +/* Need to cast, because on Haiku, the third parameter is + unsigned long buf_size. */ +_GL_CXXALIAS_SYS_CAST (initstate_r, int, + (unsigned int seed, char *buf, size_t buf_size, + struct random_data *rand_state)); # endif _GL_CXXALIASWARN (initstate_r); #elif defined GNULIB_POSIXCHECK @@ -797,8 +813,10 @@ _GL_FUNCDECL_SYS (setstate_r, int, (char *arg_state, struct random_data *rand_state) _GL_ARG_NONNULL ((1, 2))); # endif -_GL_CXXALIAS_SYS (setstate_r, int, - (char *arg_state, struct random_data *rand_state)); +/* Need to cast, because on Haiku, the first parameter is + void *arg_state. */ +_GL_CXXALIAS_SYS_CAST (setstate_r, int, + (char *arg_state, struct random_data *rand_state)); # endif _GL_CXXALIASWARN (setstate_r); #elif defined GNULIB_POSIXCHECK @@ -854,15 +872,19 @@ _GL_WARN_ON_USE (reallocarray, "reallocarray is not portable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define realpath rpl_realpath # endif -_GL_FUNCDECL_RPL (realpath, char *, (const char *name, char *resolved) - _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (realpath, char *, (const char *name, char *resolved)); +_GL_FUNCDECL_RPL (realpath, char *, + (const char *restrict name, char *restrict resolved) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (realpath, char *, + (const char *restrict name, char *restrict resolved)); # else # if !@HAVE_REALPATH@ -_GL_FUNCDECL_SYS (realpath, char *, (const char *name, char *resolved) - _GL_ARG_NONNULL ((1))); +_GL_FUNCDECL_SYS (realpath, char *, + (const char *restrict name, char *restrict resolved) + _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (realpath, char *, (const char *name, char *resolved)); +_GL_CXXALIAS_SYS (realpath, char *, + (const char *restrict name, char *restrict resolved)); # endif _GL_CXXALIASWARN (realpath); #elif defined GNULIB_POSIXCHECK @@ -945,15 +967,19 @@ _GL_WARN_ON_USE (setenv, "setenv is unportable - " # define strtod rpl_strtod # endif # define GNULIB_defined_strtod_function 1 -_GL_FUNCDECL_RPL (strtod, double, (const char *str, char **endp) - _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strtod, double, (const char *str, char **endp)); +_GL_FUNCDECL_RPL (strtod, double, + (const char *restrict str, char **restrict endp) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (strtod, double, + (const char *restrict str, char **restrict endp)); # else # if !@HAVE_STRTOD@ -_GL_FUNCDECL_SYS (strtod, double, (const char *str, char **endp) - _GL_ARG_NONNULL ((1))); +_GL_FUNCDECL_SYS (strtod, double, + (const char *restrict str, char **restrict endp) + _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strtod, double, (const char *str, char **endp)); +_GL_CXXALIAS_SYS (strtod, double, + (const char *restrict str, char **restrict endp)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (strtod); @@ -973,15 +999,19 @@ _GL_WARN_ON_USE (strtod, "strtod is unportable - " # define strtold rpl_strtold # endif # define GNULIB_defined_strtold_function 1 -_GL_FUNCDECL_RPL (strtold, long double, (const char *str, char **endp) - _GL_ARG_NONNULL ((1))); -_GL_CXXALIAS_RPL (strtold, long double, (const char *str, char **endp)); +_GL_FUNCDECL_RPL (strtold, long double, + (const char *restrict str, char **restrict endp) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (strtold, long double, + (const char *restrict str, char **restrict endp)); # else # if !@HAVE_STRTOLD@ -_GL_FUNCDECL_SYS (strtold, long double, (const char *str, char **endp) - _GL_ARG_NONNULL ((1))); +_GL_FUNCDECL_SYS (strtold, long double, + (const char *restrict str, char **restrict endp) + _GL_ARG_NONNULL ((1))); # endif -_GL_CXXALIAS_SYS (strtold, long double, (const char *str, char **endp)); +_GL_CXXALIAS_SYS (strtold, long double, + (const char *restrict str, char **restrict endp)); # endif _GL_CXXALIASWARN (strtold); #elif defined GNULIB_POSIXCHECK @@ -1003,11 +1033,13 @@ _GL_WARN_ON_USE (strtold, "strtold is unportable - " to ERANGE. */ # if !@HAVE_STRTOLL@ _GL_FUNCDECL_SYS (strtoll, long long, - (const char *string, char **endptr, int base) + (const char *restrict string, char **restrict endptr, + int base) _GL_ARG_NONNULL ((1))); # endif _GL_CXXALIAS_SYS (strtoll, long long, - (const char *string, char **endptr, int base)); + (const char *restrict string, char **restrict endptr, + int base)); _GL_CXXALIASWARN (strtoll); #elif defined GNULIB_POSIXCHECK # undef strtoll @@ -1028,11 +1060,13 @@ _GL_WARN_ON_USE (strtoll, "strtoll is unportable - " ERANGE. */ # if !@HAVE_STRTOULL@ _GL_FUNCDECL_SYS (strtoull, unsigned long long, - (const char *string, char **endptr, int base) + (const char *restrict string, char **restrict endptr, + int base) _GL_ARG_NONNULL ((1))); # endif _GL_CXXALIAS_SYS (strtoull, unsigned long long, - (const char *string, char **endptr, int base)); + (const char *restrict string, char **restrict endptr, + int base)); _GL_CXXALIASWARN (strtoull); #elif defined GNULIB_POSIXCHECK # undef strtoull diff --git a/lib/strftime.h b/lib/strftime.h index 97a062c631d..e8501631573 100644 --- a/lib/strftime.h +++ b/lib/strftime.h @@ -25,7 +25,7 @@ extern "C" { POSIX requires that strftime use the local timezone information. Use the timezone __TZ instead. Use __NS as the number of nanoseconds in the %N directive. */ -size_t nstrftime (char *, size_t, char const *, struct tm const *, +size_t nstrftime (char *restrict, size_t, char const *, struct tm const *, timezone_t __tz, int __ns); #ifdef __cplusplus diff --git a/lib/string.in.h b/lib/string.in.h index 2c04e5f4f71..aa9802791ee 100644 --- a/lib/string.in.h +++ b/lib/string.in.h @@ -54,10 +54,12 @@ /* The __attribute__ feature is available in gcc versions 2.5 and later. The attribute __pure__ was added in gcc 2.96. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) -# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) -#else -# define _GL_ATTRIBUTE_PURE /* empty */ +#ifndef _GL_ATTRIBUTE_PURE +# if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) +# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) +# else +# define _GL_ATTRIBUTE_PURE /* empty */ +# endif #endif /* NetBSD 5.0 declares strsignal in <unistd.h>, not in <string.h>. */ @@ -132,11 +134,6 @@ _GL_FUNCDECL_RPL (memchr, void *, (void const *__s, int __c, size_t __n) _GL_ARG_NONNULL ((1))); _GL_CXXALIAS_RPL (memchr, void *, (void const *__s, int __c, size_t __n)); # else -# if ! @HAVE_MEMCHR@ -_GL_FUNCDECL_SYS (memchr, void *, (void const *__s, int __c, size_t __n) - _GL_ATTRIBUTE_PURE - _GL_ARG_NONNULL ((1))); -# endif /* On some systems, this function is defined as an overloaded function: extern "C" { const void * std::memchr (const void *, int, size_t); } extern "C++" { void * std::memchr (void *, int, size_t); } */ @@ -332,9 +329,10 @@ _GL_WARN_ON_USE (stpncpy, "stpncpy is unportable - " GB18030 and the character to be searched is a digit. */ # undef strchr /* Assume strchr is always declared. */ -_GL_WARN_ON_USE (strchr, "strchr cannot work correctly on character strings " - "in some multibyte locales - " - "use mbschr if you care about internationalization"); +_GL_WARN_ON_USE_CXX (strchr, const char *, (const char *, int), + "strchr cannot work correctly on character strings " + "in some multibyte locales - " + "use mbschr if you care about internationalization"); #endif /* Find the first occurrence of C in S or the final NUL byte. */ @@ -411,11 +409,14 @@ _GL_WARN_ON_USE (strdup, "strdup is unportable - " # undef strncat # define strncat rpl_strncat # endif -_GL_FUNCDECL_RPL (strncat, char *, (char *dest, const char *src, size_t n) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (strncat, char *, (char *dest, const char *src, size_t n)); +_GL_FUNCDECL_RPL (strncat, char *, + (char *restrict dest, const char *restrict src, size_t n) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (strncat, char *, + (char *restrict dest, const char *restrict src, size_t n)); # else -_GL_CXXALIAS_SYS (strncat, char *, (char *dest, const char *src, size_t n)); +_GL_CXXALIAS_SYS (strncat, char *, + (char *restrict dest, const char *restrict src, size_t n)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (strncat); @@ -523,15 +524,17 @@ _GL_CXXALIASWARN (strpbrk); locale encoding is GB18030 and one of the characters to be searched is a digit. */ # undef strpbrk -_GL_WARN_ON_USE (strpbrk, "strpbrk cannot work correctly on character strings " - "in multibyte locales - " - "use mbspbrk if you care about internationalization"); +_GL_WARN_ON_USE_CXX (strpbrk, const char *, (const char *, const char *), + "strpbrk cannot work correctly on character strings " + "in multibyte locales - " + "use mbspbrk if you care about internationalization"); # endif #elif defined GNULIB_POSIXCHECK # undef strpbrk # if HAVE_RAW_DECL_STRPBRK -_GL_WARN_ON_USE (strpbrk, "strpbrk is unportable - " - "use gnulib module strpbrk for portability"); +_GL_WARN_ON_USE_CXX (strpbrk, const char *, (const char *, const char *), + "strpbrk is unportable - " + "use gnulib module strpbrk for portability"); # endif #endif @@ -550,9 +553,10 @@ _GL_WARN_ON_USE (strspn, "strspn cannot work correctly on character strings " GB18030 and the character to be searched is a digit. */ # undef strrchr /* Assume strrchr is always declared. */ -_GL_WARN_ON_USE (strrchr, "strrchr cannot work correctly on character strings " - "in some multibyte locales - " - "use mbsrchr if you care about internationalization"); +_GL_WARN_ON_USE_CXX (strrchr, const char *, (const char *, int), + "strrchr cannot work correctly on character strings " + "in some multibyte locales - " + "use mbsrchr if you care about internationalization"); #endif /* Search the next delimiter (char listed in DELIM) starting at *STRINGP. @@ -966,7 +970,8 @@ _GL_EXTERN_C char * mbssep (char **stringp, const char *delim) Caveat: The identity of the delimiting character is lost. See also mbssep(). */ -_GL_EXTERN_C char * mbstok_r (char *string, const char *delim, char **save_ptr) +_GL_EXTERN_C char * mbstok_r (char *restrict string, const char *delim, + char **save_ptr) _GL_ARG_NONNULL ((2, 3)); #endif diff --git a/lib/strtoimax.c b/lib/strtoimax.c index 95f6f3ff11f..a17b2f0a9d7 100644 --- a/lib/strtoimax.c +++ b/lib/strtoimax.c @@ -1,7 +1,7 @@ /* Convert string representation of a number into an intmax_t value. - Copyright (C) 1999, 2001-2004, 2006, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 1999, 2001-2004, 2006, 2009-2020 Free Software Foundation, + Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by @@ -28,36 +28,30 @@ #include "verify.h" #ifdef UNSIGNED -# if HAVE_UNSIGNED_LONG_LONG_INT -# ifndef HAVE_DECL_STRTOULL +# ifndef HAVE_DECL_STRTOULL "this configure-time declaration test was not run" -# endif -# if !HAVE_DECL_STRTOULL +# endif +# if !HAVE_DECL_STRTOULL unsigned long long int strtoull (char const *, char **, int); -# endif # endif #else -# if HAVE_LONG_LONG_INT -# ifndef HAVE_DECL_STRTOLL +# ifndef HAVE_DECL_STRTOLL "this configure-time declaration test was not run" -# endif -# if !HAVE_DECL_STRTOLL +# endif +# if !HAVE_DECL_STRTOLL long long int strtoll (char const *, char **, int); -# endif # endif #endif #ifdef UNSIGNED -# define Have_long_long HAVE_UNSIGNED_LONG_LONG_INT # define Int uintmax_t # define Strtoimax strtoumax # define Strtol strtoul # define Strtoll strtoull # define Unsigned unsigned #else -# define Have_long_long HAVE_LONG_LONG_INT # define Int intmax_t # define Strtoimax strtoimax # define Strtol strtol @@ -68,15 +62,11 @@ long long int strtoll (char const *, char **, int); Int Strtoimax (char const *ptr, char **endptr, int base) { -#if Have_long_long verify (sizeof (Int) == sizeof (Unsigned long int) || sizeof (Int) == sizeof (Unsigned long long int)); if (sizeof (Int) != sizeof (Unsigned long int)) return Strtoll (ptr, endptr, base); -#else - verify (sizeof (Int) == sizeof (Unsigned long int)); -#endif return Strtol (ptr, endptr, base); } diff --git a/lib/strtol.c b/lib/strtol.c index a2e1dee99ee..02aafca44ea 100644 --- a/lib/strtol.c +++ b/lib/strtol.c @@ -1,7 +1,7 @@ /* Convert string representation of a number into an integer value. - Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2020 Free - Software Foundation, Inc. + Copyright (C) 1991-1992, 1994-1999, 2003, 2005-2007, 2009-2020 Free Software + Foundation, Inc. NOTE: The canonical source of this file is maintained with the GNU C Library. Bugs can be reported to bug-glibc@gnu.org. diff --git a/lib/strtoll.c b/lib/strtoll.c index 0b8e03c025c..3c7e8c002f0 100644 --- a/lib/strtoll.c +++ b/lib/strtoll.c @@ -1,6 +1,6 @@ /* Function to parse a 'long long int' from text. - Copyright (C) 1995-1997, 1999, 2001, 2009-2020 Free Software - Foundation, Inc. + Copyright (C) 1995-1997, 1999, 2001, 2009-2020 Free Software Foundation, + Inc. This file is part of the GNU C Library. This program is free software: you can redistribute it and/or modify diff --git a/lib/sys_random.in.h b/lib/sys_random.in.h new file mode 100644 index 00000000000..f14ac1f5723 --- /dev/null +++ b/lib/sys_random.in.h @@ -0,0 +1,92 @@ +/* Substitute for <sys/random.h>. + Copyright (C) 2020 Free Software Foundation, Inc. + + This program is free software; you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3, or (at your option) + any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, see <https://www.gnu.org/licenses/>. */ + +# if __GNUC__ >= 3 +@PRAGMA_SYSTEM_HEADER@ +# endif +@PRAGMA_COLUMNS@ + +#ifndef _@GUARD_PREFIX@_SYS_RANDOM_H + +#if @HAVE_SYS_RANDOM_H@ + +/* On Mac OS X 10.5, <sys/random.h> assumes prior inclusion of <sys/types.h>. + On Max OS X 10.13, <sys/random.h> assumes prior inclusion of a file that + includes <Availability.h>, such as <stdlib.h> or <unistd.h>. */ +# if defined __APPLE__ && defined __MACH__ /* Mac OS X */ +# include <sys/types.h> +# include <stdlib.h> +# endif + +/* The include_next requires a split double-inclusion guard. */ +# @INCLUDE_NEXT@ @NEXT_SYS_RANDOM_H@ + +#endif + +#ifndef _@GUARD_PREFIX@_SYS_RANDOM_H +#define _@GUARD_PREFIX@_SYS_RANDOM_H + +#include <sys/types.h> + +/* Define the GRND_* constants. */ +#ifndef GRND_NONBLOCK +# define GRND_NONBLOCK 1 +# define GRND_RANDOM 2 +#endif + +/* The definitions of _GL_FUNCDECL_RPL etc. are copied here. */ + +/* The definition of _GL_ARG_NONNULL is copied here. */ + +/* The definition of _GL_WARN_ON_USE is copied here. */ + + +/* Declare overridden functions. */ + + +#if @GNULIB_GETRANDOM@ +/* Fill a buffer with random bytes. */ +# if @REPLACE_GETRANDOM@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef getrandom +# define getrandom rpl_getrandom +# endif +_GL_FUNCDECL_RPL (getrandom, ssize_t, + (void *buffer, size_t length, unsigned int flags) + _GL_ARG_NONNULL ((1))); +_GL_CXXALIAS_RPL (getrandom, ssize_t, + (void *buffer, size_t length, unsigned int flags)); +# else +# if !@HAVE_GETRANDOM@ +_GL_FUNCDECL_SYS (getrandom, ssize_t, + (void *buffer, size_t length, unsigned int flags) + _GL_ARG_NONNULL ((1))); +# endif +_GL_CXXALIAS_SYS (getrandom, ssize_t, + (void *buffer, size_t length, unsigned int flags)); +# endif +_GL_CXXALIASWARN (getrandom); +#elif defined GNULIB_POSIXCHECK +# undef getrandom +# if HAVE_RAW_DECL_GETRANDOM +_GL_WARN_ON_USE (getrandom, "getrandom is unportable - " + "use gnulib module getrandom for portability"); +# endif +#endif + + +#endif /* _@GUARD_PREFIX@_SYS_RANDOM_H */ +#endif /* _@GUARD_PREFIX@_SYS_RANDOM_H */ diff --git a/lib/sys_stat.in.h b/lib/sys_stat.in.h index c1e3243c1fe..89e167f6d1c 100644 --- a/lib/sys_stat.in.h +++ b/lib/sys_stat.in.h @@ -392,13 +392,25 @@ struct stat #if @GNULIB_FCHMODAT@ -# if !@HAVE_FCHMODAT@ +# if @REPLACE_FCHMODAT@ +# if !(defined __cplusplus && defined GNULIB_NAMESPACE) +# undef fchmodat +# define fchmodat rpl_fchmodat +# endif +_GL_FUNCDECL_RPL (fchmodat, int, + (int fd, char const *file, mode_t mode, int flag) + _GL_ARG_NONNULL ((2))); +_GL_CXXALIAS_RPL (fchmodat, int, + (int fd, char const *file, mode_t mode, int flag)); +# else +# if !@HAVE_FCHMODAT@ _GL_FUNCDECL_SYS (fchmodat, int, (int fd, char const *file, mode_t mode, int flag) _GL_ARG_NONNULL ((2))); -# endif +# endif _GL_CXXALIAS_SYS (fchmodat, int, (int fd, char const *file, mode_t mode, int flag)); +# endif _GL_CXXALIASWARN (fchmodat); #elif defined GNULIB_POSIXCHECK # undef fchmodat @@ -443,18 +455,22 @@ _GL_WARN_ON_USE (fstat, "fstat has portability problems - " # define fstatat rpl_fstatat # endif _GL_FUNCDECL_RPL (fstatat, int, - (int fd, char const *name, struct stat *st, int flags) + (int fd, char const *restrict name, struct stat *restrict st, + int flags) _GL_ARG_NONNULL ((2, 3))); _GL_CXXALIAS_RPL (fstatat, int, - (int fd, char const *name, struct stat *st, int flags)); + (int fd, char const *restrict name, struct stat *restrict st, + int flags)); # else # if !@HAVE_FSTATAT@ _GL_FUNCDECL_SYS (fstatat, int, - (int fd, char const *name, struct stat *st, int flags) + (int fd, char const *restrict name, struct stat *restrict st, + int flags) _GL_ARG_NONNULL ((2, 3))); # endif _GL_CXXALIAS_SYS (fstatat, int, - (int fd, char const *name, struct stat *st, int flags)); + (int fd, char const *restrict name, struct stat *restrict st, + int flags)); # endif _GL_CXXALIASWARN (fstatat); #elif @GNULIB_OVERRIDES_STRUCT_STAT@ @@ -499,34 +515,32 @@ _GL_WARN_ON_USE (futimens, "futimens is not portable - " #endif +#if @GNULIB_GETUMASK@ +# if !@HAVE_GETUMASK@ +_GL_FUNCDECL_SYS (getumask, mode_t, (void)); +# endif +_GL_CXXALIAS_SYS (getumask, mode_t, (void)); +# if @HAVE_GETUMASK@ +_GL_CXXALIASWARN (getumask); +# endif +#elif defined GNULIB_POSIXCHECK +# undef getumask +# if HAVE_RAW_DECL_GETUMASK +_GL_WARN_ON_USE (getumask, "getumask is not portable - " + "use gnulib module getumask for portability"); +# endif +#endif + + #if @GNULIB_LCHMOD@ /* Change the mode of FILENAME to MODE, without dereferencing it if FILENAME denotes a symbolic link. */ -# if !@HAVE_LCHMOD@ -/* The lchmod replacement follows symbolic links. Callers should take - this into account; lchmod should be applied only to arguments that - are known to not be symbolic links. On hosts that lack lchmod, - this can lead to race conditions between the check and the - invocation of lchmod, but we know of no workarounds that are - reliable in general. You might try requesting support for lchmod - from your operating system supplier. */ -# if !(defined __cplusplus && defined GNULIB_NAMESPACE) -# define lchmod chmod -# endif -/* Need to cast, because on mingw, the second parameter of chmod is - int mode. */ -_GL_CXXALIAS_RPL_CAST_1 (lchmod, chmod, int, - (const char *filename, mode_t mode)); -# else -# if 0 /* assume already declared */ +# if !@HAVE_LCHMOD@ || defined __hpux _GL_FUNCDECL_SYS (lchmod, int, (const char *filename, mode_t mode) _GL_ARG_NONNULL ((1))); -# endif -_GL_CXXALIAS_SYS (lchmod, int, (const char *filename, mode_t mode)); # endif -# if @HAVE_LCHMOD@ +_GL_CXXALIAS_SYS (lchmod, int, (const char *filename, mode_t mode)); _GL_CXXALIASWARN (lchmod); -# endif #elif defined GNULIB_POSIXCHECK # undef lchmod # if HAVE_RAW_DECL_LCHMOD @@ -543,17 +557,21 @@ _GL_WARN_ON_USE (lchmod, "lchmod is unportable - " # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define lstat stat # endif -_GL_CXXALIAS_RPL_1 (lstat, stat, int, (const char *name, struct stat *buf)); +_GL_CXXALIAS_RPL_1 (lstat, stat, int, + (const char *restrict name, struct stat *restrict buf)); # elif @REPLACE_LSTAT@ # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # undef lstat # define lstat rpl_lstat # endif -_GL_FUNCDECL_RPL (lstat, int, (const char *name, struct stat *buf) - _GL_ARG_NONNULL ((1, 2))); -_GL_CXXALIAS_RPL (lstat, int, (const char *name, struct stat *buf)); +_GL_FUNCDECL_RPL (lstat, int, + (const char *restrict name, struct stat *restrict buf) + _GL_ARG_NONNULL ((1, 2))); +_GL_CXXALIAS_RPL (lstat, int, + (const char *restrict name, struct stat *restrict buf)); # else -_GL_CXXALIAS_SYS (lstat, int, (const char *name, struct stat *buf)); +_GL_CXXALIAS_SYS (lstat, int, + (const char *restrict name, struct stat *restrict buf)); # endif # if @HAVE_LSTAT@ _GL_CXXALIASWARN (lstat); @@ -766,7 +784,7 @@ _GL_WARN_ON_USE (mknodat, "mknodat is not portable - " # define stat(name, st) rpl_stat (name, st) # endif /* !_LARGE_FILES */ # endif /* !@GNULIB_OVERRIDES_STRUCT_STAT@ */ -_GL_EXTERN_C int stat (const char *name, struct stat *buf) +_GL_EXTERN_C int stat (const char *restrict name, struct stat *restrict buf) _GL_ARG_NONNULL ((1, 2)); # endif #elif @GNULIB_OVERRIDES_STRUCT_STAT@ diff --git a/lib/tempname.c b/lib/tempname.c index 7c46ad14078..cfb0fc42eca 100644 --- a/lib/tempname.c +++ b/lib/tempname.c @@ -1,25 +1,22 @@ -/* tempname.c - generate the name of a temporary file. +/* Copyright (C) 1991-2020 Free Software Foundation, Inc. + This file is part of the GNU C Library. - Copyright (C) 1991-2003, 2005-2007, 2009-2020 Free Software - Foundation, Inc. + The GNU C Library is free software; you can redistribute it and/or + modify it under the terms of the GNU General Public + License as published by the Free Software Foundation; either + version 3 of the License, or (at your option) any later version. - This program is free software: you can redistribute it and/or modify - it under the terms of the GNU General Public License as published by - the Free Software Foundation; either version 3 of the License, or - (at your option) any later version. - - This program is distributed in the hope that it will be useful, + The GNU C Library is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of - MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the - GNU General Public License for more details. - - You should have received a copy of the GNU General Public License - along with this program. If not, see <https://www.gnu.org/licenses/>. */ + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU + General Public License for more details. -/* Extracted from glibc sysdeps/posix/tempname.c. See also tmpdir.c. */ + You should have received a copy of the GNU General Public + License along with the GNU C Library; if not, see + <https://www.gnu.org/licenses/>. */ #if !_LIBC -# include <config.h> +# include <libc-config.h> # include "tempname.h" #endif @@ -27,9 +24,6 @@ #include <assert.h> #include <errno.h> -#ifndef __set_errno -# define __set_errno(Val) errno = (Val) -#endif #include <stdio.h> #ifndef P_tmpdir @@ -53,51 +47,39 @@ #include <string.h> #include <fcntl.h> -#include <sys/time.h> #include <stdint.h> -#include <unistd.h> - +#include <sys/random.h> #include <sys/stat.h> #if _LIBC # define struct_stat64 struct stat64 +# define __secure_getenv __libc_secure_getenv #else # define struct_stat64 struct stat -# define __try_tempname try_tempname # define __gen_tempname gen_tempname -# define __getpid getpid -# define __gettimeofday gettimeofday # define __mkdir mkdir # define __open open # define __lxstat64(version, file, buf) lstat (file, buf) #endif #ifdef _LIBC -# include <hp-timing.h> -# if HP_TIMING_AVAIL -# define RANDOM_BITS(Var) \ - if (__builtin_expect (value == UINT64_C (0), 0)) \ - { \ - /* If this is the first time this function is used initialize \ - the variable we accumulate the value in to some somewhat \ - random value. If we'd not do this programs at startup time \ - might have a reduced set of possible names, at least on slow \ - machines. */ \ - struct timeval tv; \ - __gettimeofday (&tv, NULL); \ - value = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; \ - } \ - HP_TIMING_NOW (Var) -# endif -#endif - -/* Use the widest available unsigned type if uint64_t is not - available. The algorithm below extracts a number less than 62**6 - (approximately 2**35.725) from uint64_t, so ancient hosts where - uintmax_t is only 32 bits lose about 3.725 bits of randomness, - which is better than not having mkstemp at all. */ -#if !defined UINT64_MAX && !defined uint64_t -# define uint64_t uintmax_t +# include <random-bits.h> +# define RANDOM_BITS(Var) ((Var) = random_bits ()) +typedef uint32_t random_value; +# define RANDOM_VALUE_MAX UINT32_MAX +# define BASE_62_DIGITS 5 /* 62**5 < UINT32_MAX */ +# define BASE_62_POWER (62 * 62 * 62 * 62 * 62) /* 2**BASE_62_DIGITS */ +#else +/* Use getrandom if it works, falling back on a 64-bit linear + congruential generator that starts with whatever Var's value + happens to be. */ +# define RANDOM_BITS(Var) \ + ((void) (getrandom (&(Var), sizeof (Var), 0) == sizeof (Var) \ + || ((Var) = 2862933555777941757 * (Var) + 3037000493))) +typedef uint_fast64_t random_value; +# define RANDOM_VALUE_MAX UINT_FAST64_MAX +# define BASE_62_DIGITS 10 /* 62**10 < UINT_FAST64_MAX */ +# define BASE_62_POWER (62LL * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62 * 62) #endif #if _LIBC @@ -173,18 +155,80 @@ __path_search (char *tmpl, size_t tmpl_len, const char *dir, const char *pfx, } #endif /* _LIBC */ +#if _LIBC +static int try_tempname_len (char *, int, void *, int (*) (char *, void *), + size_t); +#endif + +static int +try_file (char *tmpl, void *flags) +{ + int *openflags = flags; + return __open (tmpl, + (*openflags & ~O_ACCMODE) + | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); +} + +static int +try_dir (char *tmpl, void *flags _GL_UNUSED) +{ + return __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); +} + +static int +try_nocreate (char *tmpl, void *flags _GL_UNUSED) +{ + struct_stat64 st; + + if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW) + __set_errno (EEXIST); + return errno == ENOENT ? 0 : -1; +} + /* These are the characters used in temporary file names. */ static const char letters[] = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789"; +/* Generate a temporary file name based on TMPL. TMPL must match the + rules for mk[s]temp (i.e., end in at least X_SUFFIX_LEN "X"s, + possibly with a suffix). + The name constructed does not exist at the time of the call to + this function. TMPL is overwritten with the result. + + KIND may be one of: + __GT_NOCREATE: simply verify that the name does not exist + at the time of the call. + __GT_FILE: create the file using open(O_CREAT|O_EXCL) + and return a read-write fd. The file is mode 0600. + __GT_DIR: create a directory, which will be mode 0700. + + We use a clever algorithm to get hard-to-predict names. */ +#ifdef _LIBC +static +#endif int -__try_tempname (char *tmpl, int suffixlen, void *args, - int (*tryfunc) (char *, void *)) +gen_tempname_len (char *tmpl, int suffixlen, int flags, int kind, + size_t x_suffix_len) { - int len; + static int (*const tryfunc[]) (char *, void *) = + { + [__GT_FILE] = try_file, + [__GT_DIR] = try_dir, + [__GT_NOCREATE] = try_nocreate + }; + return try_tempname_len (tmpl, suffixlen, &flags, tryfunc[kind], + x_suffix_len); +} + +#ifdef _LIBC +static +#endif +int +try_tempname_len (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *), size_t x_suffix_len) +{ + size_t len; char *XXXXXX; - static uint64_t value; - uint64_t random_time_bits; unsigned int count; int fd = -1; int save_errno = errno; @@ -194,7 +238,8 @@ __try_tempname (char *tmpl, int suffixlen, void *args, can exist for a given template is 62**6. It should never be necessary to try all of these combinations. Instead if a reasonable number of names is tried (we define reasonable as 62**3) fail to - give the system administrator the chance to remove the problems. */ + give the system administrator the chance to remove the problems. + This value requires that X_SUFFIX_LEN be at least 3. */ #define ATTEMPTS_MIN (62 * 62 * 62) /* The number of times to attempt to generate a temporary file. To @@ -205,44 +250,45 @@ __try_tempname (char *tmpl, int suffixlen, void *args, unsigned int attempts = ATTEMPTS_MIN; #endif + /* A random variable. */ + random_value v; + + /* How many random base-62 digits can currently be extracted from V. */ + int vdigits = 0; + + /* Least unfair value for V. If V is less than this, V can generate + BASE_62_DIGITS digits fairly. Otherwise it might be biased. */ + random_value const unfair_min + = RANDOM_VALUE_MAX - RANDOM_VALUE_MAX % BASE_62_POWER; + len = strlen (tmpl); - if (len < 6 + suffixlen || memcmp (&tmpl[len - 6 - suffixlen], "XXXXXX", 6)) + if (len < x_suffix_len + suffixlen + || strspn (&tmpl[len - x_suffix_len - suffixlen], "X") < x_suffix_len) { __set_errno (EINVAL); return -1; } /* This is where the Xs start. */ - XXXXXX = &tmpl[len - 6 - suffixlen]; - - /* Get some more or less random data. */ -#ifdef RANDOM_BITS - RANDOM_BITS (random_time_bits); -#else - { - struct timeval tv; - __gettimeofday (&tv, NULL); - random_time_bits = ((uint64_t) tv.tv_usec << 16) ^ tv.tv_sec; - } -#endif - value += random_time_bits ^ __getpid (); + XXXXXX = &tmpl[len - x_suffix_len - suffixlen]; - for (count = 0; count < attempts; value += 7777, ++count) + for (count = 0; count < attempts; ++count) { - uint64_t v = value; - - /* Fill in the random bits. */ - XXXXXX[0] = letters[v % 62]; - v /= 62; - XXXXXX[1] = letters[v % 62]; - v /= 62; - XXXXXX[2] = letters[v % 62]; - v /= 62; - XXXXXX[3] = letters[v % 62]; - v /= 62; - XXXXXX[4] = letters[v % 62]; - v /= 62; - XXXXXX[5] = letters[v % 62]; + for (size_t i = 0; i < x_suffix_len; i++) + { + if (vdigits == 0) + { + do + RANDOM_BITS (v); + while (unfair_min <= v); + + vdigits = BASE_62_DIGITS; + } + + XXXXXX[i] = letters[v % 62]; + v /= 62; + vdigits--; + } fd = tryfunc (tmpl, args); if (fd >= 0) @@ -259,66 +305,17 @@ __try_tempname (char *tmpl, int suffixlen, void *args, return -1; } -static int -try_file (char *tmpl, void *flags) -{ - int *openflags = flags; - return __open (tmpl, - (*openflags & ~O_ACCMODE) - | O_RDWR | O_CREAT | O_EXCL, S_IRUSR | S_IWUSR); -} - -static int -try_dir (char *tmpl, void *flags _GL_UNUSED) -{ - return __mkdir (tmpl, S_IRUSR | S_IWUSR | S_IXUSR); -} - -static int -try_nocreate (char *tmpl, void *flags _GL_UNUSED) +int +__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) { - struct_stat64 st; - - if (__lxstat64 (_STAT_VER, tmpl, &st) == 0 || errno == EOVERFLOW) - __set_errno (EEXIST); - return errno == ENOENT ? 0 : -1; + return gen_tempname_len (tmpl, suffixlen, flags, kind, 6); } -/* Generate a temporary file name based on TMPL. TMPL must match the - rules for mk[s]temp (i.e. end in "XXXXXX", possibly with a suffix). - The name constructed does not exist at the time of the call to - __gen_tempname. TMPL is overwritten with the result. - - KIND may be one of: - __GT_NOCREATE: simply verify that the name does not exist - at the time of the call. - __GT_FILE: create the file using open(O_CREAT|O_EXCL) - and return a read-write fd. The file is mode 0600. - __GT_DIR: create a directory, which will be mode 0700. - - We use a clever algorithm to get hard-to-predict names. */ +#if !_LIBC int -__gen_tempname (char *tmpl, int suffixlen, int flags, int kind) +try_tempname (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *)) { - int (*tryfunc) (char *, void *); - - switch (kind) - { - case __GT_FILE: - tryfunc = try_file; - break; - - case __GT_DIR: - tryfunc = try_dir; - break; - - case __GT_NOCREATE: - tryfunc = try_nocreate; - break; - - default: - assert (! "invalid KIND in __gen_tempname"); - abort (); - } - return __try_tempname (tmpl, suffixlen, &flags, tryfunc); + return try_tempname_len (tmpl, suffixlen, args, tryfunc, 6); } +#endif diff --git a/lib/tempname.h b/lib/tempname.h index abb92650827..00dcbe4c93b 100644 --- a/lib/tempname.h +++ b/lib/tempname.h @@ -50,6 +50,9 @@ extern "C" { We use a clever algorithm to get hard-to-predict names. */ extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); +/* Similar, except X_SUFFIX_LEN gives the number of Xs. */ +extern int gen_tempname_len (char *tmpl, int suffixlen, int flags, int kind, + size_t x_suffix_len); /* Similar to gen_tempname, but TRYFUNC is called for each temporary name to try. If TRYFUNC returns a non-negative number, TRY_GEN_TEMPNAME @@ -57,6 +60,10 @@ extern int gen_tempname (char *tmpl, int suffixlen, int flags, int kind); name is tried, or else TRY_GEN_TEMPNAME returns -1. */ extern int try_tempname (char *tmpl, int suffixlen, void *args, int (*tryfunc) (char *, void *)); +/* Similar, except X_SUFFIX_LEN gives the number of Xs. */ +extern int try_tempname_len (char *tmpl, int suffixlen, void *args, + int (*tryfunc) (char *, void *), + size_t x_suffix_len); #ifdef __cplusplus } diff --git a/lib/time.in.h b/lib/time.in.h index 3f942b704dc..1d11650e77f 100644 --- a/lib/time.in.h +++ b/lib/time.in.h @@ -286,14 +286,17 @@ _GL_CXXALIASWARN (ctime); # if !(defined __cplusplus && defined GNULIB_NAMESPACE) # define strftime rpl_strftime # endif -_GL_FUNCDECL_RPL (strftime, size_t, (char *__buf, size_t __bufsize, - const char *__fmt, const struct tm *__tp) - _GL_ARG_NONNULL ((1, 3, 4))); -_GL_CXXALIAS_RPL (strftime, size_t, (char *__buf, size_t __bufsize, - const char *__fmt, const struct tm *__tp)); +_GL_FUNCDECL_RPL (strftime, size_t, + (char *restrict __buf, size_t __bufsize, + const char *restrict __fmt, const struct tm *restrict __tp) + _GL_ARG_NONNULL ((1, 3, 4))); +_GL_CXXALIAS_RPL (strftime, size_t, + (char *restrict __buf, size_t __bufsize, + const char *restrict __fmt, const struct tm *restrict __tp)); # else -_GL_CXXALIAS_SYS (strftime, size_t, (char *__buf, size_t __bufsize, - const char *__fmt, const struct tm *__tp)); +_GL_CXXALIAS_SYS (strftime, size_t, + (char *restrict __buf, size_t __bufsize, + const char *restrict __fmt, const struct tm *restrict __tp)); # endif # if __GLIBC__ >= 2 _GL_CXXALIASWARN (strftime); diff --git a/lib/time_r.c b/lib/time_r.c index 25068ad7276..e8fca2d5c44 100644 --- a/lib/time_r.c +++ b/lib/time_r.c @@ -1,7 +1,6 @@ /* Reentrant time functions like localtime_r. - Copyright (C) 2003, 2006-2007, 2010-2020 Free Software Foundation, - Inc. + Copyright (C) 2003, 2006-2007, 2010-2020 Free Software Foundation, Inc. This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lib/unistd.in.h b/lib/unistd.in.h index ddb7c5771ba..a81a14fe873 100644 --- a/lib/unistd.in.h +++ b/lib/unistd.in.h @@ -21,7 +21,7 @@ #endif @PRAGMA_COLUMNS@ -#ifdef _GL_INCLUDING_UNISTD_H +#if @HAVE_UNISTD_H@ && defined _GL_INCLUDING_UNISTD_H /* Special invocation convention: - On Mac OS X 10.3.9 we have a sequence of nested includes <unistd.h> -> <signal.h> -> <pthread.h> -> <unistd.h> @@ -118,6 +118,17 @@ # include <netdb.h> #endif +/* Mac OS X 10.13, Solaris 11.4, and Android 9.0 declare getentropy in + <sys/random.h>, not in <unistd.h>. */ +/* But avoid namespace pollution on glibc systems. */ +#if (@GNULIB_GETENTROPY@ || defined GNULIB_POSIXCHECK) \ + && ((defined __APPLE__ && defined __MACH__) || defined __sun \ + || defined __ANDROID__) \ + && @UNISTD_H_HAVE_SYS_RANDOM_H@ \ + && !defined __GLIBC__ +# include <sys/random.h> +#endif + /* Android 4.3 declares fchownat in <sys/stat.h>, not in <unistd.h>. */ /* But avoid namespace pollution on glibc systems. */ #if (@GNULIB_FCHOWNAT@ || defined GNULIB_POSIXCHECK) && defined __ANDROID__ \ @@ -141,7 +152,7 @@ /* Get getopt(), optarg, optind, opterr, optopt. */ -#if @GNULIB_UNISTD_H_GETOPT@ && !defined _GL_SYSTEM_GETOPT +#if @GNULIB_GETOPT_POSIX@ && @GNULIB_UNISTD_H_GETOPT@ && !defined _GL_SYSTEM_GETOPT # include <getopt-cdefs.h> # include <getopt-pfx-core.h> #endif @@ -397,9 +408,6 @@ _GL_WARN_ON_USE (dup, "dup is unportable - " _GL_FUNCDECL_RPL (dup2, int, (int oldfd, int newfd)); _GL_CXXALIAS_RPL (dup2, int, (int oldfd, int newfd)); # else -# if !@HAVE_DUP2@ -_GL_FUNCDECL_SYS (dup2, int, (int oldfd, int newfd)); -# endif _GL_CXXALIAS_SYS (dup2, int, (int oldfd, int newfd)); # endif _GL_CXXALIASWARN (dup2); @@ -763,6 +771,22 @@ _GL_WARN_ON_USE (getdtablesize, "getdtablesize is unportable - " #endif +#if @GNULIB_GETENTROPY@ +/* Fill a buffer with random bytes. */ +# if !@HAVE_GETENTROPY@ +_GL_FUNCDECL_SYS (getentropy, int, (void *buffer, size_t length)); +# endif +_GL_CXXALIAS_SYS (getentropy, int, (void *buffer, size_t length)); +_GL_CXXALIASWARN (getentropy); +#elif defined GNULIB_POSIXCHECK +# undef getentropy +# if HAVE_RAW_DECL_GETENTROPY +_GL_WARN_ON_USE (getentropy, "getentropy is unportable - " + "use gnulib module getentropy for portability"); +# endif +#endif + + #if @GNULIB_GETGROUPS@ /* Return the supplemental groups that the current process belongs to. It is unspecified whether the effective group id is in the list. @@ -905,6 +929,11 @@ _GL_WARN_ON_USE (getlogin_r, "getlogin_r is unportable - " _GL_FUNCDECL_RPL (getpagesize, int, (void)); _GL_CXXALIAS_RPL (getpagesize, int, (void)); # else +/* On HP-UX, getpagesize exists, but it is not declared in <unistd.h> even if + the compiler options -D_HPUX_SOURCE -D_XOPEN_SOURCE=600 are used. */ +# if defined __hpux +_GL_FUNCDECL_SYS (getpagesize, int, (void)); +# endif # if !@HAVE_GETPAGESIZE@ # if !defined getpagesize /* This is for POSIX systems. */ @@ -1365,18 +1394,22 @@ _GL_CXXALIASWARN (read); # define readlink rpl_readlink # endif _GL_FUNCDECL_RPL (readlink, ssize_t, - (const char *file, char *buf, size_t bufsize) + (const char *restrict file, + char *restrict buf, size_t bufsize) _GL_ARG_NONNULL ((1, 2))); _GL_CXXALIAS_RPL (readlink, ssize_t, - (const char *file, char *buf, size_t bufsize)); + (const char *restrict file, + char *restrict buf, size_t bufsize)); # else # if !@HAVE_READLINK@ _GL_FUNCDECL_SYS (readlink, ssize_t, - (const char *file, char *buf, size_t bufsize) + (const char *restrict file, + char *restrict buf, size_t bufsize) _GL_ARG_NONNULL ((1, 2))); # endif _GL_CXXALIAS_SYS (readlink, ssize_t, - (const char *file, char *buf, size_t bufsize)); + (const char *restrict file, + char *restrict buf, size_t bufsize)); # endif _GL_CXXALIASWARN (readlink); #elif defined GNULIB_POSIXCHECK @@ -1394,18 +1427,22 @@ _GL_WARN_ON_USE (readlink, "readlink is unportable - " # define readlinkat rpl_readlinkat # endif _GL_FUNCDECL_RPL (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len) + (int fd, char const *restrict file, + char *restrict buf, size_t len) _GL_ARG_NONNULL ((2, 3))); _GL_CXXALIAS_RPL (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len)); + (int fd, char const *restrict file, + char *restrict buf, size_t len)); # else # if !@HAVE_READLINKAT@ _GL_FUNCDECL_SYS (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len) + (int fd, char const *restrict file, + char *restrict buf, size_t len) _GL_ARG_NONNULL ((2, 3))); # endif _GL_CXXALIAS_SYS (readlinkat, ssize_t, - (int fd, char const *file, char *buf, size_t len)); + (int fd, char const *restrict file, + char *restrict buf, size_t len)); # endif _GL_CXXALIASWARN (readlinkat); #elif defined GNULIB_POSIXCHECK @@ -1672,7 +1709,9 @@ _GL_CXXALIAS_RPL (usleep, int, (useconds_t n)); # if !@HAVE_USLEEP@ _GL_FUNCDECL_SYS (usleep, int, (useconds_t n)); # endif -_GL_CXXALIAS_SYS (usleep, int, (useconds_t n)); +/* Need to cast, because on Haiku, the first parameter is + unsigned int n. */ +_GL_CXXALIAS_SYS_CAST (usleep, int, (useconds_t n)); # endif _GL_CXXALIASWARN (usleep); #elif defined GNULIB_POSIXCHECK diff --git a/lib/utimensat.c b/lib/utimensat.c new file mode 100644 index 00000000000..63788d56480 --- /dev/null +++ b/lib/utimensat.c @@ -0,0 +1,160 @@ +/* Set the access and modification time of a file relative to directory fd. + Copyright (C) 2009-2020 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see <https://www.gnu.org/licenses/>. */ + +/* written by Eric Blake */ + +#include <config.h> + +/* Specification. */ +#include <sys/stat.h> + +#include <errno.h> +#include <fcntl.h> +#include <stdlib.h> + +#include "stat-time.h" +#include "timespec.h" +#include "utimens.h" + +#if HAVE_UTIMENSAT + +# undef utimensat + +/* If we have a native utimensat, but are compiling this file, then + utimensat was defined to rpl_utimensat by our replacement + sys/stat.h. We assume the native version might fail with ENOSYS, + or succeed without properly affecting ctime (as is the case when + using newer glibc but older Linux kernel). In this scenario, + rpl_utimensat checks whether the native version is usable, and + local_utimensat provides the fallback manipulation. */ + +static int local_utimensat (int, char const *, struct timespec const[2], int); +# define AT_FUNC_NAME local_utimensat + +/* Like utimensat, but work around native bugs. */ + +int +rpl_utimensat (int fd, char const *file, struct timespec const times[2], + int flag) +{ +# if defined __linux__ || defined __sun + struct timespec ts[2]; +# endif + + /* See comments in utimens.c for details. */ + static int utimensat_works_really; /* 0 = unknown, 1 = yes, -1 = no. */ + if (0 <= utimensat_works_really) + { + int result; +# if defined __linux__ || defined __sun + struct stat st; + /* As recently as Linux kernel 2.6.32 (Dec 2009), several file + systems (xfs, ntfs-3g) have bugs with a single UTIME_OMIT, + but work if both times are either explicitly specified or + UTIME_NOW. Work around it with a preparatory [l]stat prior + to calling utimensat; fortunately, there is not much timing + impact due to the extra syscall even on file systems where + UTIME_OMIT would have worked. + + The same bug occurs in Solaris 11.1 (Apr 2013). + + FIXME: Simplify this in 2024, when these file system bugs are + no longer common on Gnulib target platforms. */ + if (times && (times[0].tv_nsec == UTIME_OMIT + || times[1].tv_nsec == UTIME_OMIT)) + { + if (fstatat (fd, file, &st, flag)) + return -1; + if (times[0].tv_nsec == UTIME_OMIT && times[1].tv_nsec == UTIME_OMIT) + return 0; + if (times[0].tv_nsec == UTIME_OMIT) + ts[0] = get_stat_atime (&st); + else + ts[0] = times[0]; + if (times[1].tv_nsec == UTIME_OMIT) + ts[1] = get_stat_mtime (&st); + else + ts[1] = times[1]; + times = ts; + } +# ifdef __hppa__ + /* Linux kernel 2.6.22.19 on hppa does not reject invalid tv_nsec + values. */ + else if (times + && ((times[0].tv_nsec != UTIME_NOW + && ! (0 <= times[0].tv_nsec + && times[0].tv_nsec < TIMESPEC_HZ)) + || (times[1].tv_nsec != UTIME_NOW + && ! (0 <= times[1].tv_nsec + && times[1].tv_nsec < TIMESPEC_HZ)))) + { + errno = EINVAL; + return -1; + } +# endif +# endif + result = utimensat (fd, file, times, flag); + /* Linux kernel 2.6.25 has a bug where it returns EINVAL for + UTIME_NOW or UTIME_OMIT with non-zero tv_sec, which + local_utimensat works around. Meanwhile, EINVAL for a bad + flag is indeterminate whether the native utimensat works, but + local_utimensat will also reject it. */ + if (result == -1 && errno == EINVAL && (flag & ~AT_SYMLINK_NOFOLLOW)) + return result; + if (result == 0 || (errno != ENOSYS && errno != EINVAL)) + { + utimensat_works_really = 1; + return result; + } + } + /* No point in trying openat/futimens, since on Linux, futimens is + implemented with the same syscall as utimensat. Only avoid the + native utimensat due to an ENOSYS failure; an EINVAL error was + data-dependent, and the next caller may pass valid data. */ + if (0 <= utimensat_works_really && errno == ENOSYS) + utimensat_works_really = -1; + return local_utimensat (fd, file, times, flag); +} + +#else /* !HAVE_UTIMENSAT */ + +# define AT_FUNC_NAME utimensat + +#endif /* !HAVE_UTIMENSAT */ + +/* Set the access and modification timestamps of FILE to be + TIMESPEC[0] and TIMESPEC[1], respectively; relative to directory + FD. If flag is AT_SYMLINK_NOFOLLOW, change the times of a symlink, + or fail with ENOSYS if not possible. If TIMESPEC is null, set the + timestamps to the current time. If possible, do it without + changing the working directory. Otherwise, resort to using + save_cwd/fchdir, then utimens/restore_cwd. If either the save_cwd + or the restore_cwd fails, then give a diagnostic and exit nonzero. + Return 0 on success, -1 (setting errno) on failure. */ + +/* AT_FUNC_NAME is now utimensat or local_utimensat. */ +#define AT_FUNC_F1 lutimens +#define AT_FUNC_F2 utimens +#define AT_FUNC_USE_F1_COND AT_SYMLINK_NOFOLLOW +#define AT_FUNC_POST_FILE_PARAM_DECLS , struct timespec const ts[2], int flag +#define AT_FUNC_POST_FILE_ARGS , ts +#include "at-func.c" +#undef AT_FUNC_NAME +#undef AT_FUNC_F1 +#undef AT_FUNC_F2 +#undef AT_FUNC_USE_F1_COND +#undef AT_FUNC_POST_FILE_PARAM_DECLS +#undef AT_FUNC_POST_FILE_ARGS diff --git a/lib/verify.h b/lib/verify.h index d9ab89a570c..f1097612704 100644 --- a/lib/verify.h +++ b/lib/verify.h @@ -277,10 +277,22 @@ template <int w> #endif /* Assume that R always holds. Behavior is undefined if R is false, - fails to evaluate, or has side effects. Although assuming R can - help a compiler generate better code or diagnostics, performance - can suffer if R uses hard-to-optimize features such as function - calls not inlined by the compiler. */ + fails to evaluate, or has side effects. + + 'assume (R)' is a directive from the programmer telling the + compiler that R is true so the compiler needn't generate code to + test R. This is why 'assume' is in verify.h: it's related to + static checking (in this case, static checking done by the + programmer), not dynamic checking. + + 'assume (R)' can affect compilation of all the code, not just code + that happens to be executed after the assume (R) is "executed". + For example, if the code mistakenly does 'assert (R); assume (R);' + the compiler is entitled to optimize away the 'assert (R)'. + + Although assuming R can help a compiler generate better code or + diagnostics, performance can suffer if R uses hard-to-optimize + features such as function calls not inlined by the compiler. */ #if _GL_HAS_BUILTIN_UNREACHABLE # define assume(R) ((R) ? (void) 0 : __builtin_unreachable ()) diff --git a/lib/warn-on-use.h b/lib/warn-on-use.h index 1be2cbb9570..23c10fdd122 100644 --- a/lib/warn-on-use.h +++ b/lib/warn-on-use.h @@ -100,23 +100,28 @@ _GL_WARN_EXTERN_C int _gl_warn_on_use #endif /* _GL_WARN_ON_USE_CXX (function, rettype, parameters_and_attributes, "string") - is like _GL_WARN_ON_USE (function, "string"), except that the function is - declared with the given prototype, consisting of return type, parameters, - and attributes. + is like _GL_WARN_ON_USE (function, "string"), except that in C++ mode the + function is declared with the given prototype, consisting of return type, + parameters, and attributes. This variant is useful for overloaded functions in C++. _GL_WARN_ON_USE does not work in this case. */ #ifndef _GL_WARN_ON_USE_CXX -# if 4 < __GNUC__ || (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) +# if !defined __cplusplus # define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ + _GL_WARN_ON_USE (function, msg) +# else +# if 4 < __GNUC__ || (__GNUC__ == 4 && 3 <= __GNUC_MINOR__) +# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ extern rettype function parameters_and_attributes \ __attribute__ ((__warning__ (msg))) -# elif __GNUC__ >= 3 && GNULIB_STRICT_CHECKING +# elif __GNUC__ >= 3 && GNULIB_STRICT_CHECKING /* Verify the existence of the function. */ -# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ +# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ extern rettype function parameters_and_attributes -# else /* Unsupported. */ -# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ +# else /* Unsupported. */ +# define _GL_WARN_ON_USE_CXX(function,rettype,parameters_and_attributes,msg) \ _GL_WARN_EXTERN_C int _gl_warn_on_use +# endif # endif #endif diff --git a/lib/xalloc-oversized.h b/lib/xalloc-oversized.h index 6e007b566db..13ee23031a0 100644 --- a/lib/xalloc-oversized.h +++ b/lib/xalloc-oversized.h @@ -1,7 +1,6 @@ /* xalloc-oversized.h -- memory allocation size checking - Copyright (C) 1990-2000, 2003-2004, 2006-2020 Free Software - Foundation, Inc. + Copyright (C) 1990-2000, 2003-2004, 2006-2020 Free Software Foundation, Inc. This program is free software: you can redistribute it and/or modify it under the terms of the GNU General Public License as published by diff --git a/lisp/abbrev.el b/lisp/abbrev.el index 190b3504fa7..2d61a96010e 100644 --- a/lisp/abbrev.el +++ b/lisp/abbrev.el @@ -255,11 +255,7 @@ have been saved." (if (abbrev--table-symbols table) (insert-abbrev-table-description table nil))) (when (unencodable-char-position (point-min) (point-max) 'utf-8) - (setq coding-system-for-write - (if (> emacs-major-version 24) - 'utf-8-emacs - ;; For compatibility with Emacs 22 (See Bug#8308) - 'emacs-mule))) + (setq coding-system-for-write 'utf-8-emacs)) (goto-char (point-min)) (insert (format ";;-*-coding: %s;-*-\n" coding-system-for-write)) (write-region nil nil file nil (and (not verbose) 0))))) diff --git a/lisp/align.el b/lisp/align.el index c1a2b691312..61387b23dc7 100644 --- a/lisp/align.el +++ b/lisp/align.el @@ -129,6 +129,8 @@ "Hook that gets run after the aligner has been loaded." :type 'hook :group 'align) +(make-obsolete-variable 'align-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom align-indent-before-aligning nil "If non-nil, indent the marked region before aligning it." diff --git a/lisp/allout-widgets.el b/lisp/allout-widgets.el index fbdddca7d76..2a8dced5e9c 100644 --- a/lisp/allout-widgets.el +++ b/lisp/allout-widgets.el @@ -415,15 +415,17 @@ not altered with an escape sequence.") ;;;_ , Widget element formatting ;;;_ = allout-item-icon-keymap (defvar allout-item-icon-keymap - (let ((km (make-sparse-keymap))) + (let ((km (make-sparse-keymap)) + (as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + ;; The keymap parent is reset on the each local var when mode starts. + (set-keymap-parent km as-parent) (dolist (digit '("0" "1" "2" "3" "4" "5" "6" "7" "8" "9")) (define-key km digit 'digit-argument)) (define-key km "-" 'negative-argument) -;; (define-key km [(return)] 'allout-tree-expand-command) -;; (define-key km [(meta return)] 'allout-toggle-torso-command) -;; (define-key km [(down-mouse-1)] 'allout-item-button-click) -;; (define-key km [(down-mouse-2)] 'allout-toggle-torso-event-command) ;; Override underlying mouse-1 and mouse-2 bindings in icon territory: (define-key km [(mouse-1)] (lambda () (interactive) nil)) (define-key km [(mouse-2)] (lambda () (interactive) nil)) @@ -433,17 +435,16 @@ not altered with an escape sequence.") km) "General tree-node key bindings.") +(make-variable-buffer-local 'allout-item-icon-keymap) ;;;_ = allout-item-body-keymap (defvar allout-item-body-keymap (let ((km (make-sparse-keymap)) - (local-map (current-local-map))) -;; (define-key km [(control return)] 'allout-tree-expand-command) -;; (define-key km [(meta return)] 'allout-toggle-torso-command) - ;; XXX We need to reset this per buffer's mode; we do so in - ;; allout-widgets-mode. - (if local-map - (set-keymap-parent km local-map)) - + (as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + ;; The keymap parent is reset on the each local var when mode starts. + (set-keymap-parent km as-parent) km) "General key bindings for the text content of outline items.") (make-variable-buffer-local 'allout-item-body-keymap) @@ -456,6 +457,7 @@ not altered with an escape sequence.") (set-keymap-parent km allout-item-icon-keymap) km) "Keymap used in the item cue area - the space between the icon and headline.") +(make-variable-buffer-local 'allout-cue-span-keymap) ;;;_ = allout-escapes-category (defvar allout-escapes-category nil "Symbol for category of text property used to hide escapes of prefix-like @@ -566,8 +568,13 @@ outline hot-spot navigation (see `allout-mode')." (add-to-invisibility-spec '(allout-torso . t)) (add-to-invisibility-spec 'allout-escapes) - (if (current-local-map) - (set-keymap-parent allout-item-body-keymap (current-local-map))) + (let ((as-parent (if (current-local-map) + (make-composed-keymap (current-local-map) + (current-global-map)) + (current-global-map)))) + (set-keymap-parent allout-item-body-keymap as-parent) + ;; allout-cue-span-keymap uses allout-item-icon-keymap as parent. + (set-keymap-parent allout-item-icon-keymap as-parent)) (add-hook 'allout-exposure-change-functions 'allout-widgets-exposure-change-recorder nil 'local) @@ -677,7 +684,7 @@ outline hot-spot navigation (see `allout-mode')." (setplist 'allout-cue-span-category nil) (put 'allout-cue-span-category 'evaporate t) (put 'allout-cue-span-category - 'modification-hooks '(allout-body-modification-handler)) + 'modification-hooks '(allout-graphics-modification-handler)) (put 'allout-cue-span-category 'local-map allout-cue-span-keymap) (put 'allout-cue-span-category 'mouse-face widget-button-face) (put 'allout-cue-span-category 'pointer 'arrow) @@ -988,6 +995,7 @@ Generally invoked via `allout-exposure-change-functions'." ;; have to distinguish between concealing and exposing so that, eg, ;; `allout-expose-topic's mix is handled properly. handled-expose + handled-conceal covered deactivate-mark) @@ -1594,7 +1602,10 @@ We return the item-widget corresponding to the item at point." (if is-container (progn (widget-put item-widget :is-container t) (setq reverse-siblings-chart (list 1))) - (goto-char (widget-apply parent :actual-position :from)) + (let ((parent-position (widget-apply parent + :actual-position :from))) + (when parent-position + (goto-char parent-position))) (if (widget-get parent :is-container) ;; `allout-goto-prefix' will go to first non-container item: (allout-goto-prefix) @@ -1994,8 +2005,7 @@ reapplying this method will rectify the glyphs." ;; NOTE: most of the cue-area (when (not (widget-get item-widget :is-container)) - (let* ((cue-start (or (widget-get item-widget :distinctive-end) - (widget-get item-widget :icon-end))) + (let* ((cue-start (widget-get item-widget :icon-end)) (body-start (widget-get item-widget :body-start)) ;(expanded (widget-get item-widget :expanded)) ;(has-subitems (widget-get item-widget :has-subitems)) @@ -2050,19 +2060,22 @@ Optional FORCE means force reassignment of the region property." ;;;_ > allout-widgets-undecorate-region (start end) (defun allout-widgets-undecorate-region (start end) "Eliminate widgets and decorations for all items in region from START to END." - (let ((next start) - widget) + (let (done next widget + (end (or end (point-max)))) (save-excursion (goto-char start) - (while (< (setq next (next-single-char-property-change next - 'display - (current-buffer) - end)) - end) - (goto-char next) - (when (setq widget (allout-get-item-widget)) - ;; if the next-property/overly progression got us to a widget: - (allout-widgets-undecorate-item widget t)))))) + (while (not done) + (when (and (allout-on-current-heading-p) + (setq widget (allout-get-item-widget))) + (if widget + (allout-widgets-undecorate-item widget t))) + (goto-char (setq next + (next-single-char-property-change (point) + 'display + (current-buffer) + end))) + (if (>= next end) + (setq done t)))))) ;;;_ > allout-widgets-undecorate-text (text) (defun allout-widgets-undecorate-text (text) "Eliminate widgets and decorations for all items in TEXT." @@ -2389,7 +2402,7 @@ The elements of LIST are not copied, just the list structure itself." ;;;_ : provide (provide 'allout-widgets) -;;;_. Local emacs vars. -;;;_ , Local variables: -;;;_ , allout-layout: (-1 : 0) -;;;_ , End: +;;;_ . Local emacs vars. +;;;_ , Local variables: +;;;_ , allout-layout: (-1 : 0) +;;;_ , End: diff --git a/lisp/allout.el b/lisp/allout.el index 174f1e3dc21..dedad45f827 100644 --- a/lisp/allout.el +++ b/lisp/allout.el @@ -1675,10 +1675,8 @@ valid values." ;; least in emacs 21, 22.1, and xemacs 21.4. (put 'allout-exposure-category 'isearch-open-invisible 'allout-isearch-end-handler) - (if (featurep 'xemacs) - (put 'allout-exposure-category 'start-open t) - (put 'allout-exposure-category 'insert-in-front-hooks - '(allout-overlay-insert-in-front-handler))) + (put 'allout-exposure-category 'insert-in-front-hooks + '(allout-overlay-insert-in-front-handler)) (put 'allout-exposure-category 'modification-hooks '(allout-overlay-interior-modification-handler))) ;;;_ > define-minor-mode allout-mode @@ -2115,9 +2113,7 @@ internal functions use this feature cohesively bunch changes." (allout-show-to-offshoot))) (when (not first) (setq first (point)))) - (goto-char (if (featurep 'xemacs) - (next-property-change (1+ (point)) nil end) - (next-char-property-change (1+ (point)) end)))) + (goto-char (next-char-property-change (1+ (point)) end))) (when first (goto-char first) (condition-case nil @@ -2141,18 +2137,7 @@ See `allout-overlay-interior-modification-handler' for details." (when (and (allout-mode-p) undo-in-progress) (setq allout-just-did-undo t) (if (allout-hidden-p) - (allout-show-children))) - - ;; allout-overlay-interior-modification-handler on an overlay handles - ;; this in other emacs, via `allout-exposure-category's 'modification-hooks. - (when (and (featurep 'xemacs) (allout-mode-p)) - ;; process all of the pending overlays: - (save-excursion - (goto-char beg) - (let ((overlay (allout-get-invisibility-overlay))) - (if overlay - (allout-overlay-interior-modification-handler - overlay nil beg end nil)))))) + (allout-show-children)))) ;;;_ > allout-isearch-end-handler (&optional overlay) (defun allout-isearch-end-handler (&optional _overlay) "Reconcile allout outline exposure on arriving in hidden text after isearch. @@ -2453,7 +2438,7 @@ Outermost is first." (progn (if (and (not (bolp)) (allout-hidden-p (1- (point)))) - (goto-char (allout-previous-single-char-property-change + (goto-char (previous-single-char-property-change (1- (point)) 'invisible))) (move-beginning-of-line 1)) (allout-depth) @@ -3443,7 +3428,7 @@ Offer one suitable for current depth DEPTH as default." (format-message "Select bullet: %s (`%s' default): " sans-escapes - (allout-substring-no-properties default-bullet)) + (substring-no-properties default-bullet)) sans-escapes t))) (message "") @@ -4458,9 +4443,9 @@ Topic exposure is marked with text-properties, to be used by (if (not (allout-hidden-p)) (setq next (max (1+ (point)) - (allout-next-single-char-property-change (point) - 'invisible - nil end)))) + (next-single-char-property-change (point) + 'invisible + nil end)))) (if (or (not next) (eq prev next)) ;; still not at start of hidden area -- must not be any left. (setq done t) @@ -4499,7 +4484,7 @@ Topic exposure is marked with text-properties, to be used by (while (not done) ;; at or advance to start of next annotation: (if (not (get-text-property (point) 'allout-was-hidden)) - (setq next (allout-next-single-char-property-change + (setq next (next-single-char-property-change (point) 'allout-was-hidden nil end))) (if (or (not next) (eq prev next)) ;; no more or not advancing -- must not be any left. @@ -4510,7 +4495,7 @@ Topic exposure is marked with text-properties, to be used by ;; still not at start of annotation. (setq done t) ;; advance to just after end of this annotation: - (setq next (allout-next-single-char-property-change + (setq next (next-single-char-property-change (point) 'allout-was-hidden nil end)) (let ((o (make-overlay prev next nil 'front-advance))) (overlay-put o 'category 'allout-exposure-category) @@ -4543,12 +4528,12 @@ however, are left exactly like normal, non-allout-specific yanks." (interactive "*P") ; Get to beginning, leaving ; region around subject: - (if (< (allout-mark-marker t) (point)) + (if (< (mark-marker) (point)) (exchange-point-and-mark)) (save-match-data (let* ((subj-beg (point)) (into-bol (bolp)) - (subj-end (allout-mark-marker t)) + (subj-end (mark-marker)) ;; 'resituate' if yanking an entire topic into topic header: (resituate (and (let ((allout-inhibit-aberrance-doublecheck t)) (allout-e-o-prefix-p)) @@ -4642,8 +4627,8 @@ however, are left exactly like normal, non-allout-specific yanks." t))) (message "")))) (if (or into-bol resituate) - (allout-hide-by-annotation (point) (allout-mark-marker t)) - (allout-deannotate-hidden (allout-mark-marker t) (point))) + (allout-hide-by-annotation (point) (mark-marker)) + (allout-deannotate-hidden (mark-marker) (point))) (if (not resituate) (exchange-point-and-mark)) (run-hook-with-args 'allout-structure-added-functions subj-beg subj-end)))) @@ -4752,14 +4737,7 @@ this function." (when flag (let ((o (make-overlay from to nil 'front-advance))) (overlay-put o 'category 'allout-exposure-category) - (overlay-put o 'evaporate t) - (when (featurep 'xemacs) - (let ((props (symbol-plist 'allout-exposure-category))) - (while props - (condition-case nil - ;; as of 2008-02-27, xemacs lacks modification-hooks - (overlay-put o (pop props) (pop props)) - (error nil)))))) + (overlay-put o 'evaporate t)) (setq allout-this-command-hid-text t)) (run-hook-with-args 'allout-exposure-change-functions from to flag)) ;;;_ > allout-flag-current-subtree (flag) @@ -5946,7 +5924,7 @@ See `allout-toggle-current-subtree-encryption' for more details." ;; they're encrypted, so the coding system is set to accommodate ;; them. (setq buffer-file-coding-system - (allout-select-safe-coding-system subtree-beg subtree-end)) + (select-safe-coding-system subtree-beg subtree-end)) ;; if the coding system for the text being encrypted is different ;; from that prevailing, then there a real risk that the coding ;; system can't be noticed by emacs when the file is visited. to @@ -6542,204 +6520,15 @@ If BEG is bigger than END we return 0." (mapcar (lambda (char) (if (= char ?%) "%%" (char-to-string char))) string))) (define-obsolete-function-alias 'allout-flatten #'flatten-tree "27.1") -;;;_ : Compatibility: -;;;_ : xemacs undo-in-progress provision: -(unless (boundp 'undo-in-progress) - (defvar undo-in-progress nil - "Placeholder defvar for XEmacs compatibility from allout.el.") - (defadvice undo-more (around allout activate) - ;; This defadvice used only in emacs that lack undo-in-progress, eg xemacs. - (let ((undo-in-progress t)) ad-do-it))) - -;;;_ > allout-mark-marker to accommodate divergent emacsen: -(defun allout-mark-marker (&optional force buffer) - "Accommodate the different signature for `mark-marker' across Emacsen. - -XEmacs takes two optional args, while Emacs does not, -so pass them along when appropriate." - (if (featurep 'xemacs) - (apply 'mark-marker force buffer) - (mark-marker))) -;;;_ > subst-char-in-string if necessary -(if (not (fboundp 'subst-char-in-string)) - (defun subst-char-in-string (fromchar tochar string &optional inplace) - "Replace FROMCHAR with TOCHAR in STRING each time it occurs. -Unless optional argument INPLACE is non-nil, return a new string." - (let ((i (length string)) - (newstr (if inplace string (copy-sequence string)))) - (while (> i 0) - (setq i (1- i)) - (if (eq (aref newstr i) fromchar) - (aset newstr i tochar))) - newstr))) -;;;_ > wholenump if necessary -(if (not (fboundp 'wholenump)) - (defalias 'wholenump 'natnump)) -;;;_ > remove-overlays if necessary -(if (not (fboundp 'remove-overlays)) - (defun remove-overlays (&optional beg end name val) - "Clear BEG and END of overlays whose property NAME has value VAL. -Overlays might be moved and/or split. -BEG and END default respectively to the beginning and end of buffer." - (unless beg (setq beg (point-min))) - (unless end (setq end (point-max))) - (if (< end beg) - (setq beg (prog1 end (setq end beg)))) - (save-excursion - (dolist (o (overlays-in beg end)) - (when (eq (overlay-get o name) val) - ;; Either push this overlay outside beg...end - ;; or split it to exclude beg...end - ;; or delete it entirely (if it is contained in beg...end). - (if (< (overlay-start o) beg) - (if (> (overlay-end o) end) - (progn - (move-overlay (copy-overlay o) - (overlay-start o) beg) - (move-overlay o end (overlay-end o))) - (move-overlay o (overlay-start o) beg)) - (if (> (overlay-end o) end) - (move-overlay o end (overlay-end o)) - (delete-overlay o))))))) - ) -;;;_ > copy-overlay if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'copy-overlay)) - (defun copy-overlay (o) - "Return a copy of overlay O." - (let ((o1 (make-overlay (overlay-start o) (overlay-end o) - ;; FIXME: there's no easy way to find the - ;; insertion-type of the two markers. - (overlay-buffer o))) - (props (overlay-properties o))) - (while props - (overlay-put o1 (pop props) (pop props))) - o1))) -;;;_ > add-to-invisibility-spec if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'add-to-invisibility-spec)) - (defun add-to-invisibility-spec (element) - "Add ELEMENT to `buffer-invisibility-spec'. -See documentation for `buffer-invisibility-spec' for the kind of elements -that can be added." - (if (eq buffer-invisibility-spec t) - (setq buffer-invisibility-spec (list t))) - (setq buffer-invisibility-spec - (cons element buffer-invisibility-spec)))) -;;;_ > remove-from-invisibility-spec if necessary -- xemacs ~ 21.4 -(if (not (fboundp 'remove-from-invisibility-spec)) - (defun remove-from-invisibility-spec (element) - "Remove ELEMENT from `buffer-invisibility-spec'." - (if (consp buffer-invisibility-spec) - (setq buffer-invisibility-spec (delete element - buffer-invisibility-spec))))) -;;;_ > move-beginning-of-line if necessary -- older emacs, xemacs -(if (not (fboundp 'move-beginning-of-line)) - (defun move-beginning-of-line (arg) - "Move point to beginning of current line as displayed. -\(This disregards invisible newlines such as those -which are part of the text that an image rests on.) - -With argument ARG not nil or 1, move forward ARG - 1 lines first. -If point reaches the beginning or end of buffer, it stops there. -To ignore intangibility, bind `inhibit-point-motion-hooks' to t." - (interactive "p") - (or arg (setq arg 1)) - (if (/= arg 1) - (condition-case nil (line-move (1- arg)) (error nil))) - - ;; Move to beginning-of-line, ignoring fields and invisible text. - (skip-chars-backward "^\n") - (while (and (not (bobp)) - (let ((prop - (get-char-property (1- (point)) 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop buffer-invisibility-spec) - (assq prop buffer-invisibility-spec))))) - (goto-char (if (featurep 'xemacs) - (previous-property-change (point)) - (previous-char-property-change (point)))) - (skip-chars-backward "^\n")) - (vertical-motion 0)) -) -;;;_ > move-end-of-line if necessary -- Emacs < 22.1, xemacs -(if (not (fboundp 'move-end-of-line)) - (defun move-end-of-line (arg) - "Move point to end of current line as displayed. -\(This disregards invisible newlines such as those -which are part of the text that an image rests on.) - -With argument ARG not nil or 1, move forward ARG - 1 lines first. -If point reaches the beginning or end of buffer, it stops there. -To ignore intangibility, bind `inhibit-point-motion-hooks' to t." - (interactive "p") - (or arg (setq arg 1)) - (let (done) - (while (not done) - (let ((newpos - (save-excursion - (let ((goal-column 0)) - (and (condition-case nil - (or (line-move arg) t) - (error nil)) - (not (bobp)) - (progn - (while - (and - (not (bobp)) - (let ((prop - (get-char-property (1- (point)) - 'invisible))) - (if (eq buffer-invisibility-spec t) - prop - (or (memq prop - buffer-invisibility-spec) - (assq prop - buffer-invisibility-spec))))) - (goto-char - (previous-char-property-change (point)))) - (backward-char 1))) - (point))))) - (goto-char newpos) - (if (and (> (point) newpos) - (eq (preceding-char) ?\n)) - (backward-char 1) - (if (and (> (point) newpos) (not (eobp)) - (not (eq (following-char) ?\n))) - ;; If we skipped something intangible - ;; and now we're not really at eol, - ;; keep going. - (setq arg 1) - (setq done t))))))) - ) -;;;_ > allout-next-single-char-property-change -- alias unless lacking -(defalias 'allout-next-single-char-property-change - (if (fboundp 'next-single-char-property-change) - 'next-single-char-property-change - 'next-single-property-change) - ;; No docstring because xemacs defalias doesn't support it. - ) -;;;_ > allout-previous-single-char-property-change -- alias unless lacking -(defalias 'allout-previous-single-char-property-change - (if (fboundp 'previous-single-char-property-change) - 'previous-single-char-property-change - 'previous-single-property-change) - ;; No docstring because xemacs defalias doesn't support it. - ) -;;;_ > allout-select-safe-coding-system -(defalias 'allout-select-safe-coding-system - (if (fboundp 'select-safe-coding-system) - 'select-safe-coding-system - 'detect-coding-region) - ) -;;;_ > allout-substring-no-properties -;; define as alias first, so byte compiler is happy. -(defalias 'allout-substring-no-properties 'substring-no-properties) -;; then supplant with definition if underlying alias absent. -(if (not (fboundp 'substring-no-properties)) - (defun allout-substring-no-properties (string &optional start end) - (substring string (or start 0) end)) - ) - +(define-obsolete-function-alias 'allout-mark-marker #'mark-marker "28.1") +(define-obsolete-function-alias 'allout-substring-no-properties + #'substring-no-properties "28.1") +(define-obsolete-function-alias 'allout-select-safe-coding-system + #'select-safe-coding-system "28.1") +(define-obsolete-function-alias 'allout-previous-single-char-property-change + #'previous-single-char-property-change "28.1") +(define-obsolete-function-alias 'allout-next-single-char-property-change + #'next-single-char-property-change "28.1") ;;;_ #10 Unfinished ;;;_ > allout-bullet-isearch (&optional bullet) (defun allout-bullet-isearch (&optional bullet) diff --git a/lisp/apropos.el b/lisp/apropos.el index 23f70d10fd4..2566d44dfcf 100644 --- a/lisp/apropos.el +++ b/lisp/apropos.el @@ -1,4 +1,4 @@ -;;; apropos.el --- apropos commands for users and programmers +;;; apropos.el --- apropos commands for users and programmers -*- lexical-binding: t -*- ;; Copyright (C) 1989, 1994-1995, 2001-2020 Free Software Foundation, ;; Inc. @@ -82,49 +82,41 @@ commands also has an optional argument to request a more extensive search. Additionally, this option makes the function `apropos-library' include key-binding information in its output." - :group 'apropos :type 'boolean) (defface apropos-symbol '((t (:inherit bold))) "Face for the symbol name in Apropos output." - :group 'apropos :version "24.3") (defface apropos-keybinding '((t (:inherit underline))) "Face for lists of keybinding in Apropos output." - :group 'apropos :version "24.3") (defface apropos-property '((t (:inherit font-lock-builtin-face))) "Face for property name in Apropos output, or nil for none." - :group 'apropos :version "24.3") (defface apropos-function-button '((t (:inherit (font-lock-function-name-face button)))) "Button face indicating a function, macro, or command in Apropos." - :group 'apropos :version "24.3") (defface apropos-variable-button '((t (:inherit (font-lock-variable-name-face button)))) "Button face indicating a variable in Apropos." - :group 'apropos :version "24.3") (defface apropos-user-option-button '((t (:inherit (font-lock-variable-name-face button)))) "Button face indicating a user option in Apropos." - :group 'apropos :version "24.4") (defface apropos-misc-button '((t (:inherit (font-lock-constant-face button)))) "Button face indicating a miscellaneous object type in Apropos." - :group 'apropos :version "24.3") (defcustom apropos-match-face 'match @@ -132,14 +124,12 @@ include key-binding information in its output." This applies when you look for matches in the documentation or variable value for the pattern; the part that matches gets displayed in this font." :type '(choice (const nil) face) - :group 'apropos :version "24.3") (defcustom apropos-sort-by-scores nil "Non-nil means sort matches by scores; best match is shown first. This applies to all `apropos' commands except `apropos-documentation'. If value is `verbose', the computed score is shown for each match." - :group 'apropos :type '(choice (const :tag "off" nil) (const :tag "on" t) (const :tag "show scores" verbose))) @@ -148,7 +138,6 @@ If value is `verbose', the computed score is shown for each match." "Non-nil means sort matches by scores; best match is shown first. This applies to `apropos-documentation' only. If value is `verbose', the computed score is shown for each match." - :group 'apropos :type '(choice (const :tag "off" nil) (const :tag "on" t) (const :tag "show scores" verbose))) @@ -160,6 +149,10 @@ If value is `verbose', the computed score is shown for each match." ;; definition of RET, so that users can use it anywhere in an ;; apropos item, not just on top of a button. (define-key map "\C-m" 'apropos-follow) + + ;; Movement keys + (define-key map "n" 'apropos-next-symbol) + (define-key map "p" 'apropos-previous-symbol) map) "Keymap used in Apropos mode.") @@ -348,7 +341,7 @@ before finding a label." (defun apropos-words-to-regexp (words wild) - "Make regexp matching any two of the words in WORDS. + "Return a regexp matching any two of the words in WORDS. WILD should be a subexpression matching wildcards between matches." (setq words (delete-dups (copy-sequence words))) (if (null (cdr words)) @@ -380,9 +373,11 @@ kind of objects to search." (user-error "No word list given")) pattern))) -(defun apropos-parse-pattern (pattern) +(defun apropos-parse-pattern (pattern &optional multiline-p) "Rewrite a list of words to a regexp matching all permutations. If PATTERN is a string, that means it is already a regexp. +MULTILINE-P, if non-nil, means produce a regexp that will match +the words even if separated by newlines. This updates variables `apropos-pattern', `apropos-pattern-quoted', `apropos-regexp', `apropos-words', and `apropos-all-words-regexp'." (setq apropos-words nil @@ -393,6 +388,9 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted', ;; any combination of two or more words like this: ;; (a|b|c).*(a|b|c) which may give some false matches, ;; but as long as it also gives the right ones, that's ok. + ;; (Actually, when MULTILINE-P is non-nil, instead of '.' we + ;; use a trick that would find a match even if the words are + ;; on different lines. (let ((words pattern)) (setq apropos-pattern (mapconcat 'identity pattern " ") apropos-pattern-quoted (regexp-quote apropos-pattern)) @@ -409,9 +407,13 @@ This updates variables `apropos-pattern', `apropos-pattern-quoted', (setq apropos-words (cons s apropos-words) apropos-all-words (cons a apropos-all-words)))) (setq apropos-all-words-regexp - (apropos-words-to-regexp apropos-all-words ".+")) + (apropos-words-to-regexp apropos-all-words + ;; The [^b-a] trick matches any + ;; character including a newline. + (if multiline-p "[^b-a]+?" ".+"))) (setq apropos-regexp - (apropos-words-to-regexp apropos-words ".*?"))) + (apropos-words-to-regexp apropos-words + (if multiline-p "[^b-a]*?" ".*?")))) (setq apropos-pattern-quoted (regexp-quote pattern) apropos-all-words-regexp pattern apropos-pattern pattern @@ -640,7 +642,7 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Returns list of symbols and documentation found." +Return list of symbols and documentation found." (interactive (list (apropos-read-pattern "symbol") current-prefix-arg)) (setq apropos--current (list #'apropos pattern do-all)) @@ -659,12 +661,11 @@ Returns list of symbols and documentation found." (defun apropos-library-button (sym) (if (null sym) "<nothing>" - (let ((name (copy-sequence (symbol-name sym)))) + (let ((name (symbol-name sym))) (make-text-button name nil 'type 'apropos-library 'face 'apropos-symbol - 'apropos-symbol name) - name))) + 'apropos-symbol name)))) ;;;###autoload (defun apropos-library (file) @@ -794,7 +795,7 @@ Returns list of symbols and values found." (interactive (list (apropos-read-pattern "value") current-prefix-arg)) (setq apropos--current (list #'apropos-value pattern do-all)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator ()) (let (f v p) @@ -834,7 +835,7 @@ Optional arg BUFFER (default: current buffer) is the buffer to check." (interactive (list (apropos-read-pattern "value of buffer-local variable"))) (unless buffer (setq buffer (current-buffer))) (setq apropos--current (list #'apropos-local-value pattern buffer)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (setq apropos-accumulator ()) (let ((var nil)) (mapatoms @@ -876,7 +877,7 @@ Returns list of symbols and documentation found." (interactive (list (apropos-read-pattern "documentation") current-prefix-arg)) (setq apropos--current (list #'apropos-documentation pattern do-all)) - (apropos-parse-pattern pattern) + (apropos-parse-pattern pattern t) (or do-all (setq do-all apropos-do-all)) (setq apropos-accumulator () apropos-files-scanned ()) (let ((standard-input (get-buffer-create " apropos-temp")) @@ -917,16 +918,14 @@ Returns list of symbols and documentation found." (defun apropos-value-internal (predicate symbol function) - (if (funcall predicate symbol) - (progn - (setq symbol (prin1-to-string (funcall function symbol))) - (if (string-match apropos-regexp symbol) - (progn - (if apropos-match-face - (put-text-property (match-beginning 0) (match-end 0) - 'face apropos-match-face - symbol)) - symbol))))) + (when (funcall predicate symbol) + (setq symbol (prin1-to-string (funcall function symbol))) + (when (string-match apropos-regexp symbol) + (if apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + symbol)) + symbol))) (defun apropos-documentation-internal (doc) (cond @@ -948,6 +947,10 @@ Returns list of symbols and documentation found." doc)))) (defun apropos-format-plist (pl sep &optional compare) + "Return a string representation of the plist PL. +Paired elements are separated by the string SEP. Only include +properties matching the current `apropos-regexp' when COMPARE is +non-nil." (setq pl (symbol-plist pl)) (let (p p-out) (while pl @@ -956,13 +959,12 @@ Returns list of symbols and documentation found." (put-text-property 0 (length (symbol-name (car pl))) 'face 'apropos-property p) (setq p nil)) - (if p - (progn - (and compare apropos-match-face - (put-text-property (match-beginning 0) (match-end 0) - 'face apropos-match-face - p)) - (setq p-out (concat p-out (if p-out sep) p)))) + (when p + (and compare apropos-match-face + (put-text-property (match-beginning 0) (match-end 0) + 'face apropos-match-face + p)) + (setq p-out (concat p-out (if p-out sep) p))) (setq pl (nthcdr 2 pl))) p-out)) @@ -1270,6 +1272,21 @@ as a heading." (or (apropos-next-label-button (line-beginning-position)) (error "There is nothing to follow here")))) +(defun apropos-next-symbol () + "Move cursor down to the next symbol in an apropos-mode buffer." + (interactive) + (forward-line) + (while (and (not (eq (face-at-point) 'apropos-symbol)) + (< (point) (point-max))) + (forward-line))) + +(defun apropos-previous-symbol () + "Move cursor back to the last symbol in an apropos-mode buffer." + (interactive) + (forward-line -1) + (while (and (not (eq (face-at-point) 'apropos-symbol)) + (> (point) (point-min))) + (forward-line -1))) (defun apropos-describe-plist (symbol) "Display a pretty listing of SYMBOL's plist." diff --git a/lisp/arc-mode.el b/lisp/arc-mode.el index d6e85bf3835..6781c292d82 100644 --- a/lisp/arc-mode.el +++ b/lisp/arc-mode.el @@ -1,4 +1,4 @@ -;;; arc-mode.el --- simple editing of archives +;;; arc-mode.el --- simple editing of archives -*- lexical-binding: t; -*- ;; Copyright (C) 1995, 1997-1998, 2001-2020 Free Software Foundation, ;; Inc. @@ -52,17 +52,17 @@ ;; ARCHIVE TYPES: Currently only the archives below are handled, but the ;; structure for handling just about anything is in place. ;; -;; Arc Lzh Zip Zoo Rar 7z -;; -------------------------------------------- -;; View listing Intern Intern Intern Intern Y Y -;; Extract member Y Y Y Y Y Y -;; Save changed member Y Y Y Y N Y -;; Add new member N N N N N N -;; Delete member Y Y Y Y N Y -;; Rename member Y Y N N N N -;; Chmod - Y Y - N N -;; Chown - Y - - N N -;; Chgrp - Y - - N N +;; Arc Lzh Zip Zoo Rar 7z Ar +;; -------------------------------------------------- +;; View listing Intern Intern Intern Intern Y Y Y +;; Extract member Y Y Y Y Y Y Y +;; Save changed member Y Y Y Y N Y Y +;; Add new member N N N N N N N +;; Delete member Y Y Y Y N Y N +;; Rename member Y Y N N N N N +;; Chmod - Y Y - N N N +;; Chown - Y - - N N N +;; Chgrp - Y - - N N N ;; ;; Special thanks to Bill Brodie <wbrodie@panix.com> for very useful tips ;; on the first released version of this package. @@ -101,6 +101,8 @@ ;;; Code: +(eval-when-compile (require 'cl-lib)) + ;; ------------------------------------------------------------------------- ;;; Section: Configuration. @@ -108,22 +110,6 @@ "Simple editing of archives." :group 'data) -(defgroup archive-arc nil - "ARC-specific options to archive." - :group 'archive) - -(defgroup archive-lzh nil - "LZH-specific options to archive." - :group 'archive) - -(defgroup archive-zip nil - "ZIP-specific options to archive." - :group 'archive) - -(defgroup archive-zoo nil - "ZOO-specific options to archive." - :group 'archive) - (defcustom archive-tmpdir ;; make-temp-name is safe here because we use this name ;; to create a directory. @@ -131,35 +117,48 @@ (expand-file-name (if (eq system-type 'ms-dos) "ar" "archive.tmp") temporary-file-directory)) "Directory for temporary files made by `arc-mode.el'." - :type 'directory - :group 'archive) + :type 'directory) (defcustom archive-remote-regexp "^/[^/:]*[^/:.]:" "Regexp recognizing archive files names that are not local. A non-local file is one whose file name is not proper outside Emacs. A local copy of the archive will be used when updating." - :type 'regexp - :group 'archive) + :type 'regexp) (define-obsolete-variable-alias 'archive-extract-hooks 'archive-extract-hook "24.3") (defcustom archive-extract-hook nil "Hook run when an archive member has been extracted." - :type 'hook - :group 'archive) + :type 'hook) (defcustom archive-visit-single-files nil "If non-nil, opening an archive with a single file visits that file. If nil, visiting such an archive displays the archive summary." :version "25.1" :type '(choice (const :tag "Visit the single file" t) - (const :tag "Show the archive summary" nil)) - :group 'archive) + (const :tag "Show the archive summary" nil))) + +(defcustom archive-hidden-columns '(Ids) + "Columns hidden from display." + :version "28.1" + :type '(set (const Mode) + (const Ids) + (const Date&Time) + (const Ratio))) + +(defconst archive-alternate-hidden-columns '(Mode Date&Time) + "Columns hidden when `archive-alternate-display' is used.") + ;; ------------------------------ ;; Arc archive configuration ;; We always go via a local file since there seems to be no reliable way ;; to extract to stdout without junk getting added. + +(defgroup archive-arc nil + "ARC-specific options to archive." + :group 'archive) + (defcustom archive-arc-extract '("arc" "x") "Program and its options to run in order to extract an arc file member. @@ -168,8 +167,7 @@ name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-expunge '("arc" "d") @@ -178,8 +176,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) (defcustom archive-arc-write-file-member '("arc" "u") @@ -188,11 +185,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-arc) + (string :format "%v")))) ;; ------------------------------ ;; Lzh archive configuration +(defgroup archive-lzh nil + "LZH-specific options to archive." + :group 'archive) + (defcustom archive-lzh-extract '("lha" "pq") "Program and its options to run in order to extract an lzh file member. @@ -201,8 +201,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-expunge '("lha" "d") @@ -211,8 +210,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) (defcustom archive-lzh-write-file-member '("lha" "a") @@ -221,8 +219,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-lzh) + (string :format "%v")))) ;; ------------------------------ ;; Zip archive configuration @@ -231,6 +228,10 @@ Archive and member name will be added." (when 7z (file-name-nondirectory 7z)))) +(defgroup archive-zip nil + "ZIP-specific options to archive." + :group 'archive) + (defcustom archive-zip-extract (cond ((executable-find "unzip") '("unzip" "-qq" "-c")) (archive-7z-program `(,archive-7z-program "x" "-so")) @@ -242,8 +243,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) ;; For several reasons the latter behavior is not desirable in general. ;; (1) It uses more disk space. (2) Error checking is worse or non- @@ -260,8 +260,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update (cond ((executable-find "zip") '("zip" "-q")) @@ -274,8 +273,7 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (defcustom archive-zip-update-case (cond ((executable-find "zip") '("zip" "-q" "-k")) @@ -288,8 +286,7 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zip) + (string :format "%v")))) (declare-function msdos-long-file-names "msdos.c") (defcustom archive-zip-case-fiddle (and (eq system-type 'ms-dos) @@ -300,11 +297,14 @@ that uses caseless file names. In addition, this flag forces members added/updated in the zip archive to be truncated to DOS 8+3 file-name restrictions." :type 'boolean - :version "27.1" - :group 'archive-zip) + :version "27.1") ;; ------------------------------ ;; Zoo archive configuration +(defgroup archive-zoo nil + "ZOO-specific options to archive." + :group 'archive) + (defcustom archive-zoo-extract '("zoo" "xpq") "Program and its options to run in order to extract a zoo file member. @@ -313,8 +313,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-expunge '("zoo" "DqPP") @@ -323,8 +322,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) (defcustom archive-zoo-write-file-member '("zoo" "a") @@ -333,11 +331,14 @@ Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-zoo) + (string :format "%v")))) ;; ------------------------------ ;; 7z archive configuration +(defgroup archive-7z nil + "7Z-specific options to archive." + :group 'archive) + (defcustom archive-7z-extract `(,(or archive-7z-program "7z") "x" "-so") "Program and its options to run in order to extract a 7z file member. @@ -347,8 +348,7 @@ be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-expunge `(,(or archive-7z-program "7z") "d") @@ -358,8 +358,7 @@ Archive and member names will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) (defcustom archive-7z-update `(,(or archive-7z-program "7z") "u") @@ -370,18 +369,17 @@ file. Archive and member name will be added." :type '(list (string :tag "Program") (repeat :tag "Options" :inline t - (string :format "%v"))) - :group 'archive-7z) + (string :format "%v")))) ;; ------------------------------------------------------------------------- ;;; Section: Variables (defvar archive-subtype nil "Symbol describing archive type.") -(defvar archive-file-list-start nil "Position of first contents line.") -(defvar archive-file-list-end nil "Position just after last contents line.") -(defvar archive-proper-file-start nil "Position of real archive's start.") +(defvar-local archive-file-list-start nil "Position of first contents line.") +(defvar-local archive-file-list-end nil "Position just after last contents line.") +(defvar-local archive-proper-file-start nil "Position of real archive's start.") (defvar archive-read-only nil "Non-nil if the archive is read-only on disk.") -(defvar archive-local-name nil "Name of local copy of remote archive.") +(defvar-local archive-local-name nil "Name of local copy of remote archive.") (defvar archive-mode-map (let ((map (make-keymap))) (set-keymap-parent map special-mode-map) @@ -428,7 +426,6 @@ file. Archive and member name will be added." (cons "Immediate" (make-sparse-keymap "Immediate"))) (define-key map [menu-bar immediate alternate] '(menu-item "Alternate Display" archive-alternate-display - :enable (boundp (archive-name "alternate-display")) :help "Toggle alternate file info display")) (define-key map [menu-bar immediate view] '(menu-item "View This File" archive-view @@ -483,36 +480,58 @@ file. Archive and member name will be added." :help "Delete all flagged files from archive")) map) "Local keymap for archive mode listings.") -(defvar archive-file-name-indent nil "Column where file names start.") +(defvar-local archive-file-name-indent nil "Column where file names start.") -(defvar archive-remote nil "Non-nil if the archive is outside file system.") -(make-variable-buffer-local 'archive-remote) +(defvar-local archive-remote nil "Non-nil if the archive is outside file system.") (put 'archive-remote 'permanent-local t) -(defvar archive-member-coding-system nil "Coding-system of archive member.") -(make-variable-buffer-local 'archive-member-coding-system) +(defvar-local archive-member-coding-system nil "Coding-system of archive member.") -(defvar archive-alternate-display nil +(defvar-local archive-alternate-display nil "Non-nil when alternate information is shown.") -(make-variable-buffer-local 'archive-alternate-display) (put 'archive-alternate-display 'permanent-local t) (defvar archive-superior-buffer nil "In archive members, points to archive.") (put 'archive-superior-buffer 'permanent-local t) -(defvar archive-subfile-mode nil "Non-nil in archive member buffers.") -(make-variable-buffer-local 'archive-subfile-mode) +(defvar-local archive-subfile-mode nil + "Non-nil in archive member buffers. +Its value is an `archive--file-desc'.") (put 'archive-subfile-mode 'permanent-local t) -(defvar archive-file-name-coding-system nil) -(make-variable-buffer-local 'archive-file-name-coding-system) +(defvar-local archive-file-name-coding-system nil) (put 'archive-file-name-coding-system 'permanent-local t) -(defvar archive-files nil - "Vector of file descriptors. -Each descriptor is a vector of the form - [EXT-FILE-NAME INT-FILE-NAME CASE-FIDDLED MODE ...]") -(make-variable-buffer-local 'archive-files) +(cl-defstruct (archive--file-desc + (:constructor nil) + (:constructor archive--file-desc + ;; ext-file-name and int-file-name are usually `eq' + ;; except when int-file-name is the downcased + ;; ext-file-name. + (ext-file-name int-file-name mode size time + &key pos ratio uid gid))) + ext-file-name int-file-name + (mode nil :type integer) + (size nil :type integer) + (time nil :type string) + (ratio nil :type string) + uid gid + pos) + +;; Features in formats: +;; +;; ARC: size, date&time (date and time strings internally generated) +;; LZH: size, date&time, mode, uid, gid (mode, date, time generated, ugid:int) +;; ZIP: size, date&time, mode (mode, date, time generated) +;; ZOO: size, date&time (date and time strings internally generated) +;; AR : size, date&time, mode, user, group (internally generated) +;; RAR: size, date&time, ratio (all as strings, using `lsar') +;; 7Z : size, date&time (all as strings, using `7z' or `7za') +;; +;; LZH has alternate display (with UID/GID i.s.o MODE/DATE/TIME + +(defvar-local archive-files nil + "Vector of `archive--file-desc' objects.") ;; ------------------------------------------------------------------------- ;;; Section: Support functions. @@ -520,9 +539,9 @@ Each descriptor is a vector of the form (defun arc-insert-unibyte (&rest args) "Like insert but don't make unibyte string and eight-bit char multibyte." (dolist (elt args) - (if (integerp elt) - (insert (if (< elt 128) elt (decode-char 'eight-bit elt))) - (insert elt)))) + (insert (if (and (integerp elt) (>= elt 128)) + (decode-char 'eight-bit elt) + elt)))) (defsubst archive-name (suffix) (intern (concat "archive-" (symbol-name archive-subtype) "-" suffix))) @@ -544,73 +563,19 @@ in which case a second argument, length LEN, should be supplied." (aref str (- len i))))) result)) -(defun archive-int-to-mode (mode) - "Turn an integer like 0700 (i.e., 448) into a mode string like -rwx------." - ;; FIXME: merge with tar-grind-file-mode. - (string - (if (zerop (logand 8192 mode)) - (if (zerop (logand 16384 mode)) ?- ?d) - ?c) ; completeness - (if (zerop (logand 256 mode)) ?- ?r) - (if (zerop (logand 128 mode)) ?- ?w) - (if (zerop (logand 64 mode)) - (if (zerop (logand 2048 mode)) ?- ?S) - (if (zerop (logand 2048 mode)) ?x ?s)) - (if (zerop (logand 32 mode)) ?- ?r) - (if (zerop (logand 16 mode)) ?- ?w) - (if (zerop (logand 8 mode)) - (if (zerop (logand 1024 mode)) ?- ?S) - (if (zerop (logand 1024 mode)) ?x ?s)) - (if (zerop (logand 4 mode)) ?- ?r) - (if (zerop (logand 2 mode)) ?- ?w) - (if (zerop (logand 1 mode)) ?- ?x))) - -(defun archive-calc-mode (oldmode newmode &optional error) +(define-obsolete-function-alias 'archive-int-to-mode + 'file-modes-number-to-symbolic "28.1") + +(defun archive-calc-mode (oldmode newmode) "From the integer OLDMODE and the string NEWMODE calculate a new file mode. NEWMODE may be an octal number including a leading zero in which case it will become the new mode.\n NEWMODE may also be a relative specification like \"og-rwx\" in which case -OLDMODE will be modified accordingly just like chmod(2) would have done.\n -If optional third argument ERROR is non-nil an error will be signaled if -the mode is invalid. If ERROR is nil then nil will be returned." - (cond ((string-match "^0[0-7]*$" newmode) - (let ((result 0) - (len (length newmode)) - (i 1)) - (while (< i len) - (setq result (+ (ash result 3) (aref newmode i) (- ?0)) - i (1+ i))) - (logior (logand oldmode 65024) result))) - ((string-match "^\\([agou]+\\)\\([---+=]\\)\\([rwxst]+\\)$" newmode) - (let ((who 0) - (result oldmode) - (op (aref newmode (match-beginning 2))) - (bits 0) - (i (match-beginning 3))) - (while (< i (match-end 3)) - (let ((rwx (aref newmode i))) - (setq bits (logior bits (cond ((= rwx ?r) 292) - ((= rwx ?w) 146) - ((= rwx ?x) 73) - ((= rwx ?s) 3072) - ((= rwx ?t) 512))) - i (1+ i)))) - (while (< who (match-end 1)) - (let* ((whoc (aref newmode who)) - (whomask (cond ((= whoc ?a) 4095) - ((= whoc ?u) 1472) - ((= whoc ?g) 2104) - ((= whoc ?o) 7)))) - (if (= op ?=) - (setq result (logand result (lognot whomask)))) - (if (= op ?-) - (setq result (logand result (lognot (logand whomask bits)))) - (setq result (logior result (logand whomask bits))))) - (setq who (1+ who))) - result)) - (t - (if error - (error "Invalid mode specification: %s" newmode))))) +OLDMODE will be modified accordingly just like chmod(2) would have done." + ;; FIXME: Use `file-modes-symbolic-to-number'! + (if (string-match "\\`0[0-7]*\\'" newmode) + (logior (logand oldmode #o177000) (string-to-number newmode 8)) + (file-modes-symbolic-to-number newmode oldmode))) (defun archive-dosdate (date) "Stringify dos packed DATE record." @@ -622,7 +587,8 @@ the mode is invalid. If ERROR is nil then nil will be returned." (format "%2d-%s-%d" day (aref ["Jan" "Feb" "Mar" "Apr" "May" "Jun" - "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] (1- month)) + "Jul" "Aug" "Sep" "Oct" "Nov" "Dec"] + (1- month)) year)))) (defun archive-dostime (time) @@ -658,10 +624,12 @@ Does not signal an error if optional argument NOERROR is non-nil." (if (and (>= (point) archive-file-list-start) (< no (length archive-files))) (let ((item (aref archive-files no))) - (if (vectorp item) + (if (and (archive--file-desc-p item) + (let ((mode (archive--file-desc-mode item))) + (zerop (logand 16384 mode)))) item (if (not noerror) - (error "Entry is not a regular member of the archive")))) + (user-error "Entry is not a regular member of the archive")))) (if (not noerror) (error "Line does not describe a member of the archive"))))) ;; ------------------------------------------------------------------------- @@ -684,41 +652,34 @@ archive. ;; mode on and off. You can corrupt things that way. (if (zerop (buffer-size)) ;; At present we cannot create archives from scratch - (funcall (or (default-value 'major-mode) 'fundamental-mode)) + (funcall (or (default-value 'major-mode) #'fundamental-mode)) (if (and (not force) archive-files) nil (kill-all-local-variables) (let* ((type (archive-find-type)) (typename (capitalize (symbol-name type)))) - (make-local-variable 'archive-subtype) - (setq archive-subtype type) + (setq-local archive-subtype type) ;; Buffer contains treated image of file before the file contents - (make-local-variable 'revert-buffer-function) - (setq revert-buffer-function 'archive-mode-revert) - (auto-save-mode 0) + (add-function :around (local 'revert-buffer-function) + #'archive--mode-revert) - (add-hook 'write-contents-functions 'archive-write-file nil t) + (add-hook 'write-contents-functions #'archive-write-file nil t) - (make-local-variable 'require-final-newline) - (setq require-final-newline nil) - (make-local-variable 'local-enable-local-variables) - (setq local-enable-local-variables nil) + (setq-local truncate-lines t) + (setq-local require-final-newline nil) + (setq-local local-enable-local-variables nil) ;; Prevent loss of data when saving the file. - (make-local-variable 'file-precious-flag) - (setq file-precious-flag t) + (setq-local file-precious-flag t) - (make-local-variable 'archive-read-only) ;; Archives which are inside other archives and whose ;; names are invalid for this OS, can't be written. - (setq archive-read-only - (or (not (file-writable-p (buffer-file-name))) - (and archive-subfile-mode - (string-match file-name-invalid-regexp - (aref archive-subfile-mode 0))))) - - ;; Should we use a local copy when accessing from outside Emacs? - (make-local-variable 'archive-local-name) + (setq-local archive-read-only + (or (not (file-writable-p (buffer-file-name))) + (and archive-subfile-mode + (string-match file-name-invalid-regexp + (archive--file-desc-ext-file-name + archive-subfile-mode))))) ;; An archive can contain another archive whose name is invalid ;; on local filesystem. Treat such archives as remote. @@ -728,16 +689,12 @@ archive. (string-match file-name-invalid-regexp (buffer-file-name))))) - (setq major-mode 'archive-mode) + (setq major-mode #'archive-mode) (setq mode-name (concat typename "-Archive")) ;; Run archive-foo-mode-hook and archive-mode-hook (run-mode-hooks (archive-name "mode-hook") 'archive-mode-hook) (use-local-map archive-mode-map)) - (make-local-variable 'archive-proper-file-start) - (make-local-variable 'archive-file-list-start) - (make-local-variable 'archive-file-list-end) - (make-local-variable 'archive-file-name-indent) (setq archive-file-name-coding-system (or file-name-coding-system default-file-name-coding-system @@ -803,7 +760,7 @@ when parsing the archive." (let ((create-lockfiles nil) ; avoid changing dir mtime by lock_file (inhibit-read-only t)) (setq archive-proper-file-start (copy-marker (point-min) t)) - (set (make-local-variable 'change-major-mode-hook) 'archive-desummarize) + (add-hook 'change-major-mode-hook #'archive-desummarize nil t) (or shut-up (message "Parsing archive file...")) (buffer-disable-undo (current-buffer)) @@ -825,27 +782,35 @@ when parsing the archive." (goto-char archive-file-list-start) (archive-next-line no))) +(cl-defstruct (archive--file-summary + (:constructor nil) + (:constructor archive--file-summary (text name-start name-end))) + text name-start name-end) + (defun archive-summarize-files (files) "Insert a description of a list of files annotated with proper mouse face." (setq archive-file-list-start (point-marker)) - (setq archive-file-name-indent (if files (aref (car files) 1) 0)) + ;; Here we assume that they all start at the same column. + (setq archive-file-name-indent + ;; FIXME: We assume chars=columns (no double-wide chars and such). + (if files (archive--file-summary-name-start (car files)) 0)) ;; We don't want to do an insert for each element since that takes too ;; long when the archive -- which has to be moved in memory -- is large. (insert - (apply - #'concat - (mapcar - (lambda (fil) - ;; Using `concat' here copies the text also, so we can add - ;; properties without problems. - (let ((text (concat (aref fil 0) "\n"))) - (add-text-properties - (aref fil 1) (aref fil 2) - '(mouse-face highlight - help-echo "mouse-2: extract this file into a buffer") - text) - text)) - files))) + (mapconcat + (lambda (fil) + ;; Using `concat' here copies the text also, so we can add + ;; properties without problems. + (let ((text (concat (archive--file-summary-text fil) "\n"))) + (add-text-properties + (archive--file-summary-name-start fil) + (archive--file-summary-name-end fil) + '(mouse-face highlight + help-echo "mouse-2: extract this file into a buffer") + text) + text)) + files + "")) (setq archive-file-list-end (point-marker))) (defun archive-alternate-display () @@ -854,7 +819,27 @@ To avoid very long lines archive mode does not show all information. This function changes the set of information shown for each files." (interactive) (setq archive-alternate-display (not archive-alternate-display)) + (setq-local archive-hidden-columns + (if archive-alternate-display + archive-alternate-hidden-columns + (eval (car (or (get 'archive-hidden-columns 'customized-value) + (get 'archive-hidden-columns 'standard-value))) + t))) + (archive-resummarize)) + +(defun archive-hideshow-column (column) + "Toggle visibility of COLUMN." + (interactive + (list (intern + (completing-read "Toggle visibility of: " + '(Mode Ids Ratio Date&Time) + nil t)))) + (setq-local archive-hidden-columns + (if (memq column archive-hidden-columns) + (remove column archive-hidden-columns) + (cons column archive-hidden-columns))) (archive-resummarize)) + ;; ------------------------------------------------------------------------- ;;; Section: Local archive copy handling @@ -899,7 +884,8 @@ using `make-temp-file', and the generated name is returned." ;; "foo.zip:bar.zip", which is invalid on DOS/Windows. ;; So use the actual name if available. (archive-name - (or (and archive-subfile-mode (aref archive-subfile-mode 0)) + (or (and archive-subfile-mode (archive--file-desc-ext-file-name + archive-subfile-mode)) archive))) (setq archive-local-name (archive-unique-fname archive-name archive-tmpdir)) @@ -918,6 +904,7 @@ using `make-temp-file', and the generated name is returned." (lno (archive-get-lineno)) (inhibit-read-only t)) (if unchanged nil + ;; FIXME: Use archive-resummarize? (setq archive-files nil) (erase-buffer) (insert-file-contents name) @@ -968,7 +955,7 @@ using `make-temp-file', and the generated name is returned." (delete-file tmpfile))))) (defun archive-file-name-handler (op &rest args) - (or (eq op 'file-exists-p) + (or (eq op #'file-exists-p) (let ((file-name-handler-alist nil)) (apply op args)))) @@ -1008,8 +995,8 @@ using `make-temp-file', and the generated name is returned." (if event (posn-set-point (event-end event))) (let* ((view-p (eq other-window-p 'view)) (descr (archive-get-descr)) - (ename (aref descr 0)) - (iname (aref descr 1)) + (ename (archive--file-desc-ext-file-name descr)) + (iname (archive--file-desc-int-file-name descr)) (archive-buffer (current-buffer)) (arcdir default-directory) (archive (buffer-file-name)) @@ -1038,8 +1025,7 @@ using `make-temp-file', and the generated name is returned." (abbreviate-file-name buffer-file-name)) ;; Set the default-directory to the dir of the superior buffer. (setq default-directory arcdir) - (make-local-variable 'archive-superior-buffer) - (setq archive-superior-buffer archive-buffer) + (setq-local archive-superior-buffer archive-buffer) (add-hook 'write-file-functions #'archive-write-file-member nil t) (setq archive-subfile-mode descr) (setq archive-file-name-coding-system file-name-coding) @@ -1253,7 +1239,7 @@ using `make-temp-file', and the generated name is returned." t) (defun archive-*-write-file-member (archive descr command) - (let* ((ename (aref descr 0)) + (let* ((ename (archive--file-desc-ext-file-name descr)) (tmpfile (expand-file-name ename archive-tmpdir)) (top (directory-file-name (file-name-as-directory archive-tmpdir))) (default-directory (file-name-as-directory top))) @@ -1270,9 +1256,10 @@ using `make-temp-file', and the generated name is returned." ;; further processing clobbers it (we restore it in ;; archive-write-file-member, above). (setq archive-member-coding-system last-coding-system-used) - (if (aref descr 3) + (if (archive--file-desc-mode descr) ;; Set the file modes, but make sure we can read it. - (set-file-modes tmpfile (logior ?\400 (aref descr 3)))) + (set-file-modes tmpfile + (logior ?\400 (archive--file-desc-mode descr)))) (setq ename (encode-coding-string ename archive-file-name-coding-system)) (let* ((coding-system-for-write 'no-conversion) @@ -1376,7 +1363,7 @@ Use \\[archive-unmark-all-files] to remove all marks." "Change the protection bits associated with all marked or this member. The new protection bits can either be specified as an octal number or as a relative change like \"g+rw\" as for chmod(2)." - (interactive "sNew mode (octal or relative): ") + (interactive "sNew mode (octal or symbolic): ") (if archive-read-only (error "Archive is read-only")) (let ((func (archive-name "chmod-entry"))) (if (fboundp func) @@ -1415,7 +1402,9 @@ as a relative change like \"g+rw\" as for chmod(2)." (goto-char archive-file-list-start) (while (< (point) archive-file-list-end) (if (= (following-char) ?D) - (setq files (cons (aref (archive-get-descr) 0) files))) + (setq files (cons (archive--file-desc-ext-file-name + (archive-get-descr)) + files))) (forward-line 1))) (setq files (nreverse files)) (and files @@ -1461,12 +1450,11 @@ as a relative change like \"g+rw\" as for chmod(2)." (error "Renaming is not supported for this archive type")))) ;; Revert the buffer and recompute the dired-like listing. -(defun archive-mode-revert (&optional _no-auto-save _no-confirm) +(defun archive--mode-revert (orig-fun &rest args) (let ((no (archive-get-lineno))) (setq archive-files nil) - (let ((revert-buffer-function nil) - (coding-system-for-read 'no-conversion)) - (revert-buffer t t)) + (let ((coding-system-for-read 'no-conversion)) + (apply orig-fun t t (cddr args))) (archive-mode) (goto-char archive-file-list-start) (archive-next-line no))) @@ -1477,15 +1465,135 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (interactive) (let ((inhibit-read-only t)) (undo))) + +(defun archive--fit (str len) + (let* ((spaces (- len (string-width str))) + (pre (/ spaces 2))) + (if (< spaces 1) + (substring str 0 len) + (concat (make-string pre ?\s) str (make-string (- spaces pre) ?\s))))) + +(defun archive--fit2 (str1 str2 len) + (let* ((spaces (- len (string-width str1) (string-width str2)))) + (if (< spaces 1) + (substring (concat str1 str2) 0 len) + (concat str1 (make-string spaces ?\s) str2)))) + +(defun archive--enabled-p (column) + (not (memq column archive-hidden-columns))) + +(defun archive--summarize-descs (descs) + (goto-char (point-min)) + (if (null descs) + (progn (insert "M ... Filename\n") + (insert "- ----- ---------------\n") + (archive-summarize-files nil) + (insert "- ----- ---------------\n")) + (let* ((sample (car descs)) + (maxsize 0) + (maxidlen 0) + (totalsize 0) + (times (archive--enabled-p 'Date&Time)) + (ids (and (archive--enabled-p 'Ids) + (or (archive--file-desc-uid sample) + (archive--file-desc-gid sample)))) + ;; For ratio, date/time, and mode, we presume that + ;; they're either present on all entries or on nonel, and that they + ;; take the same space on each of them. + (ratios (and (archive--enabled-p 'Ratio) + (archive--file-desc-ratio sample))) + (ratiolen (if ratios (string-width ratios))) + (timelen (length (archive--file-desc-time sample))) + (samplemode (and (archive--enabled-p 'Mode) + (archive--file-desc-mode sample))) + (modelen (length (if samplemode (file-modes-number-to-symbolic samplemode))))) + (dolist (desc descs) + (when ids + (let* ((uid (archive--file-desc-uid desc)) + (gid (archive--file-desc-uid desc)) + (len (cond + ((not uid) (string-width gid)) + ((not gid) (string-width uid)) + (t (+ (string-width uid) (string-width gid) 1))))) + (if (> len maxidlen) (setq maxidlen len)))) + (let ((size (archive--file-desc-size desc))) + (cl-incf totalsize size) + (if (> size maxsize) (setq maxsize size)))) + (let* ((sizelen (length (number-to-string maxsize))) + (dash + (concat + "- " + (if (> modelen 0) (concat (make-string modelen ?-) " ")) + (if ids (concat (make-string maxidlen ?-) " ")) + (make-string sizelen ?-) " " + (if ratios (concat (make-string (1+ ratiolen) ?-) " ")) + " " + (if times (concat (make-string timelen ?-) " ")) + "----------------\n")) + (startcol (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen 2 + (if ratios (+ 2 ratiolen) 0) + (if times (+ timelen 2) 0)))) + (insert + (concat "M " + (if (> modelen 0) (concat (archive--fit "Mode" modelen) " ")) + (if ids (concat (archive--fit2 "Uid" "Gid" maxidlen) " ")) + (archive--fit "Size" sizelen) " " + (if ratios (concat (archive--fit "Cmp" (1+ ratiolen)) " ")) + " " + (if times (concat (archive--fit "Date&time" timelen) " ")) + " Filename\n")) + (insert dash) + (archive-summarize-files + (mapcar (lambda (desc) + (let* ((size (number-to-string + (archive--file-desc-size desc))) + (text + (concat " " + (when (> modelen 0) + (concat (file-modes-number-to-symbolic + (archive--file-desc-mode desc)) + " ")) + (when ids + (concat (archive--fit2 + (archive--file-desc-uid desc) + (archive--file-desc-gid desc) + maxidlen) " ")) + (make-string (- sizelen (length size)) ?\s) + size + " " + (when ratios + (concat (archive--file-desc-ratio desc) + "% ")) + " " + (when times + (concat (archive--file-desc-time desc) + " ")) + (archive--file-desc-int-file-name desc)))) + (archive--file-summary + text startcol (length text)))) + descs)) + (insert dash) + (insert (format (format "%%%dd %%s %%d files\n" + (+ 2 + (if (> modelen 0) (+ 2 modelen) 0) + (if ids (+ maxidlen 2) 0) + sizelen)) + totalsize + (make-string (+ (if times (+ 2 timelen) 0) + (if ratios (+ 2 ratiolen) 0) 1) + ?\s) + (length descs)))))) + (apply #'vector descs)) + ;; ------------------------------------------------------------------------- ;;; Section: Arc Archives (defun archive-arc-summarize () (let ((p 1) - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (and (< (+ p 29) (point-max)) (= (get-byte p) ?\C-z) (> (get-byte (1+ p)) 0)) @@ -1498,48 +1606,28 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (modtime (archive-l-e (+ p 21) 2)) (ucsize (archive-l-e (+ p 25) 4)) (fiddle (string= efnname (upcase efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen fnlen) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) files) p (+ p 29 csize)))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-arc-rename-entry (newname descr) (if (string-match "[:\\/]" newname) (error "File names in arc files must not contain a directory component")) (if (> (length newname) 12) (error "File names in arc files are limited to 12 characters")) - (let ((name (concat newname (substring "\0\0\0\0\0\0\0\0\0\0\0\0\0" - (length newname)))) + (let ((name (concat newname (make-string (- 13 (length newname)) ?\0))) (inhibit-read-only t)) (save-restriction (save-excursion (widen) - (goto-char (+ archive-proper-file-start (aref descr 4) 2)) + (goto-char (+ archive-proper-file-start 2 + (archive--file-desc-pos descr))) (delete-char 13) (arc-insert-unibyte name))))) ;; ------------------------------------------------------------------------- @@ -1547,10 +1635,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-summarize (&optional start) (let ((p (or start 1)) ;; 1 for .lzh, something further on for .exe - (totalsize 0) - (maxlen 8) - files - visual) + files) (while (progn (goto-char p) ;beginning of a base header. (looking-at "\\(.\\|\n\\)\\(.\\|\n\\)-l[hz][0-9ds]-")) (let* ((hsize (get-byte p)) ;size of the base header (level 0 and 1) @@ -1561,9 +1646,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (time2 (archive-l-e (+ p 17) 2)) ;and UNIX format in level 2 header.) (hdrlvl (get-byte (+ p 20))) ;header level thsize ;total header size (base + extensions) - fnlen efnname osid fiddle ifnname width p2 + fnlen efnname osid fiddle ifnname p2 neh ;beginning of next extension header (level 1 and 2) - mode modestr uid gid text dir prname + mode uid gid dir prname gname uname modtime moddate) (if (= hdrlvl 3) (error "can't handle lzh level 3 header type")) (when (or (= hdrlvl 0) (= hdrlvl 1)) @@ -1576,26 +1661,26 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (setq neh (+ p2 3)) ;specific to level 1 header (if (= hdrlvl 2) (setq neh (+ p 24)))) ;specific to level 2 header - (if neh ;if level 1 or 2 we expect extension headers to follow + (if neh ;if level 1 or 2 we expect extension headers to follow (let* ((ehsize (archive-l-e neh 2)) ;size of the extension header (etype (get-byte (+ neh 2)))) ;extension type (while (not (= ehsize 0)) - (cond - ((= etype 1) ;file name + (cond + ((= etype 1) ;file name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) (setq efnname (concat efnname (char-to-string (get-byte i)))) (setq i (1+ i))))) - ((= etype 2) ;directory name + ((= etype 2) ;directory name (let ((i (+ neh 3))) (while (< i (+ neh ehsize)) - (setq dir (concat dir - (if (= (get-byte i) - 255) - "/" - (char-to-string - (char-after i))))) - (setq i (1+ i))))) + (setq dir (concat dir + (if (= (get-byte i) + 255) + "/" + (char-to-string + (char-after i))))) + (setq i (1+ i))))) ((= etype 80) ;Unix file permission (setq mode (archive-l-e (+ neh 3) 2))) ((= etype 81) ;UNIX file group/user ID @@ -1611,7 +1696,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (while (< i (+ neh ehsize)) (setq uname (concat uname (char-to-string (char-after i)))) (setq i (1+ i))))) - ) + ) (setq neh (+ neh ehsize)) (setq ehsize (archive-l-e neh 2)) (setq etype (get-byte (+ neh 2)))) @@ -1637,60 +1722,25 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ((= 0 osid) (string= efnname (upcase efnname))))) (setq ifnname (if fiddle (downcase efnname) efnname)) (setq prname (if dir (concat dir ifnname) ifnname)) - (setq width (if prname (string-width prname) 0)) - (setq modestr (if mode (archive-int-to-mode mode) "??????????")) (setq moddate (if (= hdrlvl 2) (archive-unixdate time1 time2) ;level 2 header in UNIX format (archive-dosdate time2))) ;level 0 and 1 header in DOS format (setq modtime (if (= hdrlvl 2) (archive-unixtime time1 time2) (archive-dostime time1))) - (setq text (if archive-alternate-display - (format " %8d %5S %5S %s" - ucsize - (or uid "?") - (or gid "?") - ifnname) - (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - moddate - modtime - prname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length prname)) - (length text)) - visual) - files (cons (vector prname ifnname fiddle mode (1- p)) - files)) + (push (archive--file-desc + prname ifnname mode ucsize + (concat moddate " " modtime) + :pos (1- p) + :uid (or uname (if uid (number-to-string uid))) + :gid (or gname (if gid (number-to-string gid)))) + files) (cond ((= hdrlvl 1) (setq p (+ p hsize 2 csize))) ((or (= hdrlvl 2) (= hdrlvl 0)) (setq p (+ p thsize 2 csize)))) )) - (goto-char (point-min)) - (let ((dash (concat (if archive-alternate-display - "- -------- ----- ----- " - "- ---------- -------- ----------- -------- ") - (make-string maxlen ?-) - "\n")) - (header (if archive-alternate-display - "M Length Uid Gid File\n" - "M Filemode Length Date Time File\n")) - (sumline (if archive-alternate-display - " %8.0f %d file%s" - " %8.0f %d file%s"))) - (insert header dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format sumline - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defconst archive-lzh-alternate-display t) @@ -1709,7 +1759,8 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (save-excursion (widen) - (let* ((p (+ archive-proper-file-start (aref descr 4))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos descr))) (oldhsize (get-byte p)) (oldfnlen (get-byte (+ p 21))) (newfnlen (length newname)) @@ -1729,7 +1780,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (save-restriction (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (aref fil 4))) + (let* ((p (+ archive-proper-file-start (archive--file-desc-pos fil))) (hsize (get-byte p)) (fnlen (get-byte (+ p 21))) (p2 (+ p 22 fnlen)) @@ -1746,7 +1797,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (delete-char 1) (arc-insert-unibyte (archive-lzh-resum (1+ p) hsize))) (message "Member %s does not have %s field" - (aref fil 1) errtxt))))))) + (archive--file-desc-int-file-name fil) errtxt))))))) (defun archive-lzh-chown-entry (newuid files) (archive-lzh-ogm newuid files "an uid" 10)) @@ -1756,8 +1807,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-lzh-chmod-entry (newmode files) (archive-lzh-ogm - ;; This should work even though newmode will be dynamically accessed. - (lambda (old) (archive-calc-mode old newmode t)) + (lambda (old) (archive-calc-mode old newmode)) files "a unix-style mode" 8)) ;; ------------------------------------------------------------------------- @@ -1794,11 +1844,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (- (point-max) (- 22 18))) (search-backward-regexp "[P]K\005\006") (let ((p (archive-l-e (+ (point) 16) 4)) - (maxlen 8) - (totalsize 0) - files - visual - emacs-int-has-32bits) + files) (when (= p -1) ;; If the offset of end-of-central-directory is -1, this is a ;; Zip64 extended ZIP file format, and we need to glean the info @@ -1824,7 +1870,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (fnlen (archive-l-e (+ p 28) 2)) (exlen (archive-l-e (+ p 30) 2)) (fclen (archive-l-e (+ p 32) 2)) - (lheader (archive-l-e (+ p 42) 4)) + ;; (lheader (archive-l-e (+ p 42) 4)) (efnname (let ((str (buffer-substring (+ p 46) (+ p 46 fnlen)))) (decode-coding-string str archive-file-name-coding-system))) @@ -1839,44 +1885,18 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (logand 1 (get-byte (+ p 38)))) ?\222 0))) (t nil))) - (modestr (if mode (archive-int-to-mode mode) "??????????")) (fiddle (and archive-zip-case-fiddle - (not (not (memq creator '(0 2 4 5 9)))) + (memq creator '(0 2 4 5 9)) (string= (upcase efnname) efnname))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %10s %8d %-11s %-8s %s" - modestr - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (if isdir - nil - (vector efnname ifnname fiddle mode - (list (1- p) lheader))) - files) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname mode ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime)) + :pos (1- p)) + files) p (+ p 46 fnlen exlen fclen)))) - (goto-char (point-min)) - (let ((dash (concat "- ---------- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Filemode Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zip-extract (archive name) (cond @@ -1901,21 +1921,27 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." name) archive-zip-extract)))) +(defun archive--file-desc-case-fiddled (fd) + (not (eq (archive--file-desc-int-file-name fd) + (archive--file-desc-ext-file-name fd)))) + (defun archive-zip-write-file-member (archive descr) (archive-*-write-file-member archive descr - (if (aref descr 2) archive-zip-update-case archive-zip-update))) + (if (archive--file-desc-case-fiddled descr) + archive-zip-update-case archive-zip-update))) (defun archive-zip-chmod-entry (newmode files) (save-restriction (save-excursion (widen) (dolist (fil files) - (let* ((p (+ archive-proper-file-start (car (aref fil 4)))) + (let* ((p (+ archive-proper-file-start + (archive--file-desc-pos fil))) (creator (get-byte (+ p 5))) - (oldmode (aref fil 3)) - (newval (archive-calc-mode oldmode newmode t)) + (oldmode (archive--file-desc-mode fil)) + (newval (archive-calc-mode oldmode newmode)) (inhibit-read-only t)) (cond ((memq creator '(2 3)) ; Unix (goto-char (+ p 40)) @@ -1934,10 +1960,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defun archive-zoo-summarize () (let ((p (1+ (archive-l-e 25 4))) - (maxlen 8) - (totalsize 0) - files - visual) + files) (while (and (string= "\334\247\304\375" (buffer-substring p (+ p 4))) (> (archive-l-e (+ p 6) 4) 0)) (let* ((next (1+ (archive-l-e (+ p 6) 4))) @@ -1964,36 +1987,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (decode-coding-string str archive-file-name-coding-system))) (fiddle (and (= lfnlen 0) (string= efnname (upcase efnname)))) - (ifnname (if fiddle (downcase efnname) efnname)) - (width (string-width ifnname)) - (text (format " %8d %-11s %-8s %s" - ucsize - (archive-dosdate moddate) - (archive-dostime modtime) - ifnname))) - (setq maxlen (max maxlen width) - totalsize (+ totalsize ucsize) - visual (cons (vector text - (- (length text) (length ifnname)) - (length text)) - visual) - files (cons (vector efnname ifnname fiddle nil (1- p)) + (ifnname (if fiddle (downcase efnname) efnname))) + (setq files (cons (archive--file-desc + efnname ifnname nil ucsize + (concat (archive-dosdate moddate) + " " (archive-dostime modtime))) files) p next))) - (goto-char (point-min)) - (let ((dash (concat "- -------- ----------- -------- " - (make-string maxlen ?-) - "\n"))) - (insert "M Length Date Time File\n" - dash) - (archive-summarize-files (nreverse visual)) - (insert dash - (format " %8d %d file%s" - totalsize - (length files) - (if (= 1 (length files)) "" "s")) - "\n")) - (apply #'vector (nreverse files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-zoo-extract (archive name) (archive-extract-by-stdout archive name archive-zoo-extract)) @@ -2005,17 +2006,16 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; File is used internally for `archive-rar-exe-summarize'. (unless file (setq file buffer-file-name)) (let* ((copy (file-local-copy file)) - (maxname 10) - (maxsize 5) (files ())) (with-temp-buffer - (call-process "lsar" nil t nil "-l" (or file copy)) - (if copy (delete-file copy)) + (unwind-protect + (call-process "lsar" nil t nil "-l" (or file copy)) + (if copy (delete-file copy))) (goto-char (point-min)) - (re-search-forward "^\\(\s+=+\s*\\)+\n") + (re-search-forward "^\\(?:\s+=+\\)+\s*\n") (while (looking-at (concat "^\s+[0-9.]+\s+D?-+\s+" ; Flags "\\([0-9-]+\\)\s+" ; Size - "\\([-0-9.%]+\\)\s+" ; Ratio + "\\([-0-9.]+\\)%?\s+" ; Ratio "\\([0-9a-zA-Z]+\\)\s+" ; Mode "\\([0-9-]+\\)\s+" ; Date "\\([0-9:]+\\)\s+" ; Time @@ -2024,36 +2024,14 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (goto-char (match-end 0)) (let ((name (match-string 6)) (size (match-string 1))) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name name nil nil - ;; Size, Ratio. - size (match-string 2) - ;; Date, Time. - (match-string 4) (match-string 5)) + (push (archive--file-desc name name nil + ;; Size + (string-to-number size) + ;; Date&Time. + (concat (match-string 4) " " (match-string 5)) + :ratio (match-string 2)) files)))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format " %%s %%s %%%ds %%5s %%s" maxsize)) - (sep (format format "----------" "-----" (make-string maxsize ?-) - "-----" "")) - (column (length sep))) - (insert (format format " Date " "Time " "Size" "Ratio" "Filename") "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 6) - (aref desc 7) - (aref desc 4) - (aref desc 5) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-rar-extract (archive name) ;; unrar-free seems to have no way to extract to stdout or even to a file. @@ -2100,9 +2078,7 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;;; Section: 7z Archives (defun archive-7z-summarize () - (let ((maxname 10) - (maxsize 5) - (file buffer-file-name) + (let ((file buffer-file-name) (files ())) (with-temp-buffer (call-process archive-7z-program nil t nil "l" "-slt" file) @@ -2119,29 +2095,9 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (time (save-excursion (and (re-search-forward "^Modified = \\(.*\\)\n") (match-string 1))))) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name name nil nil time nil nil size) + (push (archive--file-desc name name nil (string-to-number size) time) files)))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format " %%%ds %%s %%s" maxsize)) - (sep (format format (make-string maxsize ?-) "-------------------" "")) - (column (length sep))) - (insert (format format "Size " "Date Time " " Filename") "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 7) - (aref desc 4) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-7z-extract (archive name) ;; 7z doesn't provide a `quiet' option to suppress non-essential @@ -2168,79 +2124,43 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (defconst archive-ar-file-header-re "\\(.\\{16\\}\\)\\([ 0-9]\\{12\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-9]\\{6\\}\\)\\([ 0-7]\\{8\\}\\)\\([ 0-9]\\{10\\}\\)`\n") +(defun archive-ar--name (name) + "Return the external name represented by the entry NAME. +NAME is expected to be the 16-bytes part of an ar record." + (cond ((equal name "// ") + (propertize ".<ExtNamesTable>." 'face 'italic)) + ((equal name "/ ") + (propertize ".<LookupTable>." 'face 'italic)) + ((string-match "/? *\\'" name) + ;; FIXME: Decode? Add support for longer names? + (substring name 0 (match-beginning 0))))) + (defun archive-ar-summarize () ;; File is used internally for `archive-rar-exe-summarize'. - (let* ((maxname 10) - (maxtime 16) - (maxuser 5) - (maxgroup 5) - (maxmode 8) - (maxsize 5) - (files ())) + (let* ((files ())) (goto-char (point-min)) (search-forward "!<arch>\n") (while (looking-at archive-ar-file-header-re) - (let ((name (match-string 1)) - extname - (time (string-to-number (match-string 2))) - (user (match-string 3)) - (group (match-string 4)) - (mode (string-to-number (match-string 5) 8)) - (size (string-to-number (match-string 6)))) + (let* ((name (match-string 1)) + extname + (time (string-to-number (match-string 2))) + (user (match-string 3)) + (group (match-string 4)) + (mode (string-to-number (match-string 5) 8)) + (sizestr (match-string 6)) + (size (string-to-number sizestr))) ;; Move to the beginning of the data. (goto-char (match-end 0)) (setq time (format-time-string "%Y-%m-%d %H:%M" time)) - (setq extname - (cond ((equal name "// ") - (propertize ".<ExtNamesTable>." 'face 'italic)) - ((equal name "/ ") - (propertize ".<LookupTable>." 'face 'italic)) - ((string-match "/? *\\'" name) - (substring name 0 (match-beginning 0))))) + (setq extname (archive-ar--name name)) (setq user (substring user 0 (string-match " +\\'" user))) (setq group (substring group 0 (string-match " +\\'" group))) - (setq mode (tar-grind-file-mode mode)) ;; Move to the end of the data. (forward-char size) (if (eq ?\n (char-after)) (forward-char 1)) - (setq size (number-to-string size)) - (if (> (length name) maxname) (setq maxname (length name))) - (if (> (length time) maxtime) (setq maxtime (length time))) - (if (> (length user) maxuser) (setq maxuser (length user))) - (if (> (length group) maxgroup) (setq maxgroup (length group))) - (if (> (length mode) maxmode) (setq maxmode (length mode))) - (if (> (length size) maxsize) (setq maxsize (length size))) - (push (vector name extname nil mode - time user group size) + (push (archive--file-desc extname extname mode size time + :uid user :gid group) files))) - (setq files (nreverse files)) - (goto-char (point-min)) - (let* ((format (format "%%%ds %%%ds/%%-%ds %%%ds %%%ds %%s" - maxmode maxuser maxgroup maxsize maxtime)) - (sep (format format (make-string maxmode ?-) - (make-string maxuser ?-) - (make-string maxgroup ?-) - (make-string maxsize ?-) - (make-string maxtime ?-) "")) - (column (length sep))) - (insert (format format " Mode " "User" "Group" " Size " - " Date " "Filename") - "\n") - (insert sep (make-string maxname ?-) "\n") - (archive-summarize-files (mapcar (lambda (desc) - (let ((text - (format format - (aref desc 3) - (aref desc 5) - (aref desc 6) - (aref desc 7) - (aref desc 4) - (aref desc 1)))) - (vector text - column - (length text)))) - files)) - (insert sep (make-string maxname ?-) "\n") - (apply #'vector files)))) + (archive--summarize-descs (nreverse files)))) (defun archive-ar-extract (archive name) (let ((destbuf (current-buffer)) @@ -2257,10 +2177,11 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." (let ((this (match-string 1))) (setq size (string-to-number (match-string 6))) (goto-char (match-end 0)) - (if (equal name this) + (if (equal name (archive-ar--name this)) (setq from (point)) ;; Move to the end of the data. - (forward-char size) (if (eq ?\n (char-after)) (forward-char 1))))) + (forward-char size) + (if (eq ?\n (char-after)) (forward-char 1))))) (when from (set-buffer-multibyte nil) (with-current-buffer destbuf @@ -2270,6 +2191,13 @@ This doesn't recover lost files, it just undoes changes in the buffer itself." ;; Inform the caller that the call succeeded. t)))))) +(defun archive-ar-write-file-member (archive descr) + (archive-*-write-file-member + archive + descr + '("ar" "r"))) + + ;; ------------------------------------------------------------------------- ;; This line was a mistake; it is kept now for compatibility. ;; rms 15 Oct 98 diff --git a/lisp/autoarg.el b/lisp/autoarg.el index c0307aa92b1..d41527775f4 100644 --- a/lisp/autoarg.el +++ b/lisp/autoarg.el @@ -1,4 +1,4 @@ -;;; autoarg.el --- make digit keys supply prefix args +;;; autoarg.el --- make digit keys supply prefix args -*- lexical-binding: t -*- ;; Copyright (C) 1998, 2000-2020 Free Software Foundation, Inc. @@ -59,9 +59,8 @@ ;; (define-key autoarg-mode-map [?\r] 'autoarg-terminate) (defvar autoarg-kp-digits - (let (alist) - (dotimes (i 10 alist) - (push (cons (intern (format "kp-%d" i)) i) alist)))) + (mapcar (lambda (i) (cons (intern (format "kp-%d" i)) i)) + (reverse (number-sequence 0 9)))) (defun autoarg-kp-digit-argument (arg) "Part of the numeric argument for the next command, like `digit-argument'." diff --git a/lisp/autoinsert.el b/lisp/autoinsert.el index 25961d41089..4af3d631a2c 100644 --- a/lisp/autoinsert.el +++ b/lisp/autoinsert.el @@ -396,7 +396,7 @@ Matches the visited file name against the elements of `auto-insert-alist'." ;; which might ask the user for something (switch-to-buffer (current-buffer)) (if (and (consp action) - (not (eq (car action) 'lambda))) + (not (functionp action))) (skeleton-insert action) (funcall action))))) (if (vectorp action) diff --git a/lisp/autorevert.el b/lisp/autorevert.el index 011febfe728..6e08176f5ff 100644 --- a/lisp/autorevert.el +++ b/lisp/autorevert.el @@ -242,6 +242,8 @@ For more information, see Info node `(emacs)Autorevert'." :tag "Load Hook" :group 'auto-revert :type 'hook) +(make-obsolete-variable 'auto-revert-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom auto-revert-check-vc-info nil "If non-nil Auto-Revert Mode reliably updates version control info. diff --git a/lisp/battery.el b/lisp/battery.el index 1d3390070c3..e568ab52460 100644 --- a/lisp/battery.el +++ b/lisp/battery.el @@ -1,8 +1,9 @@ -;;; battery.el --- display battery status information +;;; battery.el --- display battery status information -*- lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2020 Free Software Foundation, Inc. ;; Author: Ralph Schleicher <rs@ralph-schleicher.de> +;; Maintainer: emacs-devel@gnu.org ;; Keywords: hardware ;; This file is part of GNU Emacs. @@ -22,15 +23,19 @@ ;;; Commentary: -;; There is at present support for GNU/Linux, macOS and Windows. This -;; library supports both the `/proc/apm' file format of Linux version -;; 1.3.58 or newer and the `/proc/acpi/' directory structure of Linux -;; 2.4.20 and 2.6. Darwin (macOS) is supported by using the `pmset' -;; program. Windows is supported by the GetSystemPowerStatus API call. +;; There is at present support for GNU/Linux, BSD, macOS, and Windows. +;; This library supports: +;; - UPower (https://upower.freedesktop.org) via D-Bus API. +;; - The `/sys/class/power_supply/' files of Linux >= 2.6.39. +;; - The `/proc/acpi/' directory structure of Linux 2.4.20 and 2.6. +;; - The `/proc/apm' file format of Linux version 1.3.58 or newer. +;; - BSD by using the `apm' program. +;; - Darwin (macOS) by using the `pmset' program. +;; - Windows via the GetSystemPowerStatus API call. ;;; Code: -(require 'timer) +(require 'dbus) (eval-when-compile (require 'cl-lib)) (defgroup battery nil @@ -38,41 +43,75 @@ :prefix "battery-" :group 'hardware) -(defcustom battery-upower-device "battery_BAT1" - "Upower battery device name." - :version "26.1" - :type 'string - :group 'battery) +(defcustom battery-upower-device nil + "Preferred UPower device name(s). +When `battery-status-function' is set to `battery-upower', this +user option specifies which power sources to query for status +information and merge into a single report. + +When nil (the default), `battery-upower' queries all present +battery and line power devices as determined by the UPower +EnumerateDevices method. A string or a nonempty list of strings +names particular devices to query instead. UPower battery and +line power device names typically follow the patterns +\"battery_BATN\" and \"line_power_ACN\", respectively, with N +starting at 0 when present. Device names should not include the +leading D-Bus path \"/org/freedesktop/UPower/devices/\"." + :version "28.1" + :type '(choice (const :tag "Autodetect all devices" nil) + (string :tag "Device") + (repeat :tag "Devices" string))) + +(defcustom battery-upower-subscribe t + "Whether to subscribe to UPower device change signals. +When nil, battery status information is polled every +`battery-update-interval' seconds. When non-nil (the default), +the battery status is also updated whenever a power source is +added or removed, or when the system starts or stops running on +battery power. + +This only takes effect when `battery-status-function' is set to +`battery-upower' before enabling `display-battery-mode'." + :version "28.1" + :type 'boolean) + +(defconst battery-upower-service "org.freedesktop.UPower" + "Well-known name of the UPower D-Bus service. +See URL `https://upower.freedesktop.org/docs/ref-dbus.html'.") + +(defun battery--files (dir) + "Return a list of absolute file names in DIR or nil on error. +Value does not include \".\" or \"..\"." + (ignore-errors (directory-files dir t directory-files-no-dot-files-regexp))) (defun battery--find-linux-sysfs-batteries () - (let ((dirs nil)) - (dolist (file (directory-files "/sys/class/power_supply/" t)) - (when (and (or (file-directory-p file) - (file-symlink-p file)) - (file-exists-p (expand-file-name "capacity" file))) - (push file dirs))) + "Return a list of all sysfs battery directories." + (let (dirs) + (dolist (dir (battery--files "/sys/class/power_supply/")) + (when (file-exists-p (expand-file-name "capacity" dir)) + (push dir dirs))) (nreverse dirs))) (defcustom battery-status-function - (cond ((and (eq system-type 'gnu/linux) - (file-readable-p "/proc/apm")) - #'battery-linux-proc-apm) + (cond ((member battery-upower-service (dbus-list-activatable-names)) + #'battery-upower) + ((and (eq system-type 'gnu/linux) + (battery--find-linux-sysfs-batteries)) + #'battery-linux-sysfs) ((and (eq system-type 'gnu/linux) (file-directory-p "/proc/acpi/battery")) #'battery-linux-proc-acpi) ((and (eq system-type 'gnu/linux) - (file-directory-p "/sys/class/power_supply/") - (battery--find-linux-sysfs-batteries)) - #'battery-linux-sysfs) + (file-readable-p "/proc/apm")) + #'battery-linux-proc-apm) ((and (eq system-type 'berkeley-unix) (file-executable-p "/usr/sbin/apm")) #'battery-bsd-apm) ((and (eq system-type 'darwin) - (condition-case nil - (with-temp-buffer - (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) - (> (buffer-size) 0))) - (error nil))) + (ignore-errors + (with-temp-buffer + (and (eq (call-process "pmset" nil t nil "-g" "ps") 0) + (not (bobp)))))) #'battery-pmset) ((fboundp 'w32-battery-status) #'w32-battery-status)) @@ -84,8 +123,8 @@ Its cons cells are of the form CONVERSION is the character code of a \"conversion specification\" introduced by a `%' character in a control string." - :type '(choice (const nil) function) - :group 'battery) + :version "28.1" + :type '(choice (const nil) function)) (defcustom battery-echo-area-format "Power %L, battery %B (%p%% load, remaining time %t)" @@ -96,17 +135,20 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min'" - :type '(choice string (const nil)) - :group 'battery) +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") + :type '(choice string (const nil))) (defvar battery-mode-line-string nil "String to display in the mode line.") @@ -115,11 +157,10 @@ string are substituted as defined by the current value of the variable (defcustom battery-mode-line-limit 100 "Percentage of full battery load below which display battery status." :version "24.1" - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-mode-line-format - (cond ((eq battery-status-function 'battery-linux-proc-acpi) + (cond ((eq battery-status-function #'battery-linux-proc-acpi) "[%b%p%%,%d°C]") (battery-status-function "[%b%p%%]")) @@ -130,34 +171,46 @@ string are substituted as defined by the current value of the variable `battery-status-function'. Here are the ones generally available: %c Current capacity (mAh or mWh) %r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status: empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage +%s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours -%t Remaining time (to charge or discharge) in the form `h:min'" - :type '(choice string (const nil)) - :group 'battery) +%t Remaining time (to charge or discharge) in the form `h:min' + +The full `format-spec' formatting syntax is supported." + :link '(info-link "(elisp) Custom Format Strings") + :type '(choice string (const nil))) (defcustom battery-update-interval 60 "Seconds after which the battery status will be updated." - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-load-low 25 "Upper bound of low battery load percentage. A battery load percentage below this number is considered low." - :type 'integer - :group 'battery) + :type 'integer) (defcustom battery-load-critical 10 "Upper bound of critical battery load percentage. A battery load percentage below this number is considered critical." - :type 'integer - :group 'battery) + :type 'integer) + +(defface battery-load-low + '((t :inherit warning)) + "Face used in mode line string when battery load is low. +See the option `battery-load-low'." + :version "28.1") + +(defface battery-load-critical + '((t :inherit error)) + "Face used in mode line string when battery load is critical. +See the option `battery-load-critical'." + :version "28.1") (defvar battery-update-timer nil "Interval timer object.") @@ -181,17 +234,21 @@ The text displayed in the mode line is controlled by `battery-mode-line-format' and `battery-status-function'. The mode line is be updated every `battery-update-interval' seconds." - :global t :group 'battery + :global t (setq battery-mode-line-string "") (or global-mode-string (setq global-mode-string '(""))) (and battery-update-timer (cancel-timer battery-update-timer)) + (battery--upower-unsubscribe) (if (and battery-status-function battery-mode-line-format) (if (not display-battery-mode) (setq global-mode-string (delq 'battery-mode-line-string global-mode-string)) (add-to-list 'global-mode-string 'battery-mode-line-string t) + (and (eq battery-status-function #'battery-upower) + battery-upower-subscribe + (battery--upower-subsribe)) (setq battery-update-timer (run-at-time nil battery-update-interval - 'battery-update-handler)) + #'battery-update-handler)) (battery-update)) (message "Battery status not available") (setq display-battery-mode nil))) @@ -203,34 +260,42 @@ seconds." (defun battery-update () "Update battery status information in the mode line." (let* ((data (and battery-status-function (funcall battery-status-function))) - (percentage (car (read-from-string (cdr (assq ?p data)))))) - (setq battery-mode-line-string - (propertize (if (and battery-mode-line-format - (numberp percentage) - (<= percentage battery-mode-line-limit)) - (battery-format battery-mode-line-format data) - "") - 'face - (and (numberp percentage) - (<= percentage battery-load-critical) - 'error) - 'help-echo "Battery status information"))) - (force-mode-line-update)) + (percentage (car (read-from-string (cdr (assq ?p data))))) + (res (and battery-mode-line-format + (or (not (numberp percentage)) + (<= percentage battery-mode-line-limit)) + (battery-format battery-mode-line-format data))) + (len (length res))) + (unless (zerop len) + (cond ((not (numberp percentage))) + ((< percentage battery-load-critical) + (add-face-text-property 0 len 'battery-load-critical t res)) + ((< percentage battery-load-low) + (add-face-text-property 0 len 'battery-load-low t res))) + (put-text-property 0 len 'help-echo "Battery status information" res)) + (setq battery-mode-line-string (or res ""))) + (force-mode-line-update t)) + ;;; `/proc/apm' interface for Linux. -(defconst battery-linux-proc-apm-regexp - (concat "^\\([^ ]+\\)" ; Driver version. - " \\([^ ]+\\)" ; APM BIOS version. - " 0x\\([0-9a-f]+\\)" ; APM BIOS flags. - " 0x\\([0-9a-f]+\\)" ; AC line status. - " 0x\\([0-9a-f]+\\)" ; Battery status. - " 0x\\([0-9a-f]+\\)" ; Battery flags. - " \\(-?[0-9]+\\)%" ; Load percentage. - " \\(-?[0-9]+\\)" ; Remaining time. - " \\(.*\\)" ; Time unit. - "$") +;; Regular expression matching contents of `/proc/apm'. +(rx-define battery--linux-proc-apm + (: bol (group (+ (not ?\s))) ; Driver version. + " " (group (+ (not ?\s))) ; APM BIOS version. + " 0x" (group (+ xdigit)) ; APM BIOS flags. + " 0x" (group (+ xdigit)) ; AC line status. + " 0x" (group (+ xdigit)) ; Battery status. + " 0x" (group (+ xdigit)) ; Battery flags. + " " (group (? ?-) (+ digit)) ?% ; Load percentage. + " " (group (? ?-) (+ digit)) ; Remaining time. + " " (group (* nonl)) ; Time unit + eol)) + +(defconst battery-linux-proc-apm-regexp (rx battery--linux-proc-apm) "Regular expression matching contents of `/proc/apm'.") +(make-obsolete-variable 'battery-linux-proc-apm-regexp + "it is no longer used." "28.1") (defun battery-linux-proc-apm () "Get APM status information from Linux (the kernel). @@ -250,12 +315,12 @@ The following %-sequences are provided: %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let (driver-version bios-version bios-interface line-status - battery-status battery-status-symbol load-percentage - seconds minutes hours remaining-time tem) + (let ( driver-version bios-version bios-interface line-status + battery-status battery-status-symbol load-percentage + seconds minutes hours remaining-time tem ) (with-temp-buffer (ignore-errors (insert-file-contents "/proc/apm")) - (when (re-search-forward battery-linux-proc-apm-regexp) + (when (re-search-forward (rx battery--linux-proc-apm) nil t) (setq driver-version (match-string 1)) (setq bios-version (match-string 2)) (setq tem (string-to-number (match-string 3) 16)) @@ -268,9 +333,7 @@ The following %-sequences are provided: (cond ((= tem 0) (setq line-status "off-line")) ((= tem 1) (setq line-status "on-line")) ((= tem 2) (setq line-status "on backup"))) - (setq tem (string-to-number (match-string 6) 16)) - (if (= tem 255) - (setq battery-status "N/A") + (unless (= (string-to-number (match-string 6) 16) 255) (setq tem (string-to-number (match-string 5) 16)) (cond ((= tem 0) (setq battery-status "high" battery-status-symbol "")) @@ -287,7 +350,7 @@ The following %-sequences are provided: (setq minutes (/ seconds 60) hours (/ seconds 3600)) (setq remaining-time - (format "%d:%02d" hours (- minutes (* 60 hours)))))))) + (format "%d:%02d" hours (% minutes 60))))))) (list (cons ?v (or driver-version "N/A")) (cons ?V (or bios-version "N/A")) (cons ?I (or bios-interface "N/A")) @@ -295,27 +358,31 @@ The following %-sequences are provided: (cons ?B (or battery-status "N/A")) (cons ?b (or battery-status-symbol "")) (cons ?p (or load-percentage "N/A")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) + (cons ?s (if seconds (number-to-string seconds) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?h (if hours (number-to-string hours) "N/A")) (cons ?t (or remaining-time "N/A"))))) ;;; `/proc/acpi/' interface for Linux. +(rx-define battery--acpi-rate (&rest hour) + (: (group (+ digit)) " " (group ?m (in "AW") hour))) +(rx-define battery--acpi-capacity (battery--acpi-rate ?h)) + (defun battery-linux-proc-acpi () "Get ACPI status information from Linux (the kernel). -This function works only with the `/proc/acpi/' format introduced -in Linux version 2.4.20 and 2.6.0. +This function works only with the `/proc/acpi/' interface +introduced in Linux version 2.4.20 and 2.6.0. The following %-sequences are provided: %c Current capacity (mAh) -%r Current rate +%r Current rate of charge or discharge +%L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) -%L AC line status (verbose) %p Battery load percentage %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours @@ -331,45 +398,51 @@ The following %-sequences are provided: ;; information together since displaying for a variable amount of ;; batteries seems overkill for format-strings. (with-temp-buffer - (dolist (dir (ignore-errors (directory-files "/proc/acpi/battery/" - t "\\`[^.]"))) - (erase-buffer) - (ignore-errors (insert-file-contents (expand-file-name "state" dir))) - (when (re-search-forward "present: +yes$" nil t) - (and (re-search-forward "charging state: +\\(.*\\)$" nil t) + (dolist (dir (battery--files "/proc/acpi/battery/")) + (ignore-errors + (insert-file-contents (expand-file-name "state" dir) nil nil nil t)) + (goto-char (point-min)) + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (and (re-search-forward (rx "charging state:" (+ space) + (group (not space) (* nonl)) eol) + nil t) (member charging-state '("unknown" "charged" nil)) ;; On most multi-battery systems, most of the time only one ;; battery is "charging"/"discharging", the others are ;; "unknown". (setq charging-state (match-string 1))) - (when (re-search-forward "present rate: +\\([0-9]+\\) \\(m[AW]\\)$" + (when (re-search-forward (rx "present rate:" (+ space) + (battery--acpi-rate) eol) nil t) (setq rate (+ (or rate 0) (string-to-number (match-string 1)))) (when (> rate 0) - (setq rate-type (or (and rate-type - (if (string= rate-type (match-string 2)) - rate-type - (error - "Inconsistent rate types (%s vs. %s)" - rate-type (match-string 2)))) - (match-string 2))))) - (when (re-search-forward "remaining capacity: +\\([0-9]+\\) m[AW]h$" + (cond ((not rate-type) + (setq rate-type (match-string 2))) + ((not (string= rate-type (match-string 2))) + (error "Inconsistent rate types (%s vs. %s)" + rate-type (match-string 2)))))) + (when (re-search-forward (rx "remaining capacity:" (+ space) + battery--acpi-capacity eol) nil t) (setq capacity (+ (or capacity 0) (string-to-number (match-string 1)))))) (goto-char (point-max)) (ignore-errors (insert-file-contents (expand-file-name "info" dir))) - (when (re-search-forward "present: +yes$" nil t) - (when (re-search-forward "design capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "present:" (+ space) "yes" eol) nil t) + (when (re-search-forward (rx "design capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf design-capacity (string-to-number (match-string 1)))) - (when (re-search-forward "last full capacity: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "last full capacity:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf last-full-capacity (string-to-number (match-string 1)))) - (when (re-search-forward - "design capacity warning: +\\([0-9]+\\) m[AW]h$" nil t) + (when (re-search-forward (rx "design capacity warning:" (+ space) + battery--acpi-capacity eol) + nil t) (cl-incf warn (string-to-number (match-string 1)))) - (when (re-search-forward "design capacity low: +\\([0-9]+\\) m[AW]h$" + (when (re-search-forward (rx "design capacity low:" (+ space) + battery--acpi-capacity eol) nil t) (cl-incf low (string-to-number (match-string 1))))))) (setq full-capacity (if (> last-full-capacity 0) @@ -383,77 +456,70 @@ The following %-sequences are provided: 60) rate)) hours (/ minutes 60))) - (list (cons ?c (or (and capacity (number-to-string capacity)) "N/A")) + (list (cons ?c (if capacity (number-to-string capacity) "N/A")) (cons ?L (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/state")) - (ignore-errors - (directory-files "/proc/acpi/ac_adapter/" - t "\\`[^.]"))) - "state: +\\(.*\\)$" 1) - + (mapcar (lambda (d) (expand-file-name "state" d)) + (battery--files "/proc/acpi/ac_adapter/")) + (rx "state:" (+ space) (group (not space) (* nonl)) eol) + 1) "N/A")) (cons ?d (or (battery-search-for-one-match-in-files - (mapcar (lambda (e) (concat e "/temperature")) - (ignore-errors - (directory-files "/proc/acpi/thermal_zone/" - t "\\`[^.]"))) - "temperature: +\\([0-9]+\\) C$" 1) - + (mapcar (lambda (d) (expand-file-name "temperature" d)) + (battery--files "/proc/acpi/thermal_zone/")) + (rx "temperature:" (+ space) (group (+ digit)) " C" eol) + 1) "N/A")) - (cons ?r (or (and rate (concat (number-to-string rate) " " - rate-type)) "N/A")) + (cons ?r (if rate + (concat (number-to-string rate) " " rate-type) + "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?b (or (and (string= charging-state "charging") "+") - (and capacity (< capacity low) "!") - (and capacity (< capacity warn) "-") - "")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?t (or (and minutes - (format "%d:%02d" hours (- minutes (* 60 hours)))) - "N/A")) - (cons ?p (or (and full-capacity capacity - (> full-capacity 0) - (number-to-string - (floor (* 100 capacity) full-capacity))) - "N/A"))))) + (cons ?b (cond ((string= charging-state "charging") "+") + ((and capacity (< capacity low)) "!") + ((and capacity (< capacity warn)) "-") + (""))) + (cons ?h (if hours (number-to-string hours) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?t (if minutes (format "%d:%02d" hours (% minutes 60)) "N/A")) + (cons ?p (if (and full-capacity capacity (> full-capacity 0)) + (number-to-string (floor (* 100 capacity) full-capacity)) + "N/A"))))) ;;; `/sys/class/power_supply/BATN' interface for Linux. (defun battery-linux-sysfs () - "Get ACPI status information from Linux kernel. + "Get sysfs status information from Linux kernel. This function works only with the new `/sys/class/power_supply/' -format introduced in Linux version 2.4.25. +interface introduced in Linux version 2.4.25. The following %-sequences are provided: %c Current capacity (mAh or mWh) -%r Current rate +%r Current rate of charge or discharge +%L Power source (verbose) %B Battery status (verbose) +%b Battery status, empty means high, `-' means low, + `!' means critical, and `+' means charging %d Temperature (in degrees Celsius) %p Battery load percentage -%L AC line status (verbose) %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let (charging-state temperature hours - ;; Some batteries report charges and current, other energy and power. + (let (;; Some batteries report charges and current, others energy and power. ;; In order to reliably be able to combine those data, we convert them ;; all to energy/power (since we can't combine different charges if ;; they're not at the same voltage). (energy-full 0.0) (energy-now 0.0) (power-now 0.0) - (voltage-now 10.8)) ;Arbitrary default, in case the info is missing. + (voltage-now 10.8) ; Arbitrary default, in case the info is missing. + charging-state temperature hours percentage-now) ;; SysFS provides information about each battery present in the ;; system in a separate subdirectory. We are going to merge the ;; available information together. (with-temp-buffer - (dolist (dir (ignore-errors - (battery--find-linux-sysfs-batteries))) - (erase-buffer) - (ignore-errors (insert-file-contents - (expand-file-name "uevent" dir))) + (dolist (dir (battery--find-linux-sysfs-batteries)) + (ignore-errors + (insert-file-contents (expand-file-name "uevent" dir) nil nil nil t)) (goto-char (point-min)) (when (re-search-forward "POWER_SUPPLY_VOLTAGE_NOW=\\([0-9]*\\)$" nil t) @@ -489,7 +555,7 @@ The following %-sequences are provided: voltage-now)) (cl-incf energy-now (* (string-to-number now-string) voltage-now))) - ((and (progn (goto-char (point-min)) t) + ((and (goto-char (point-min)) (re-search-forward "POWER_SUPPLY_ENERGY_FULL=\\([0-9]*\\)$" nil t) (setq full-string (match-string 1)) @@ -498,15 +564,16 @@ The following %-sequences are provided: (setq now-string (match-string 1))) (cl-incf energy-full (string-to-number full-string)) (cl-incf energy-now (string-to-number now-string))))) - (goto-char (point-min)) (unless (zerop power-now) (let ((remaining (if (string= charging-state "Discharging") energy-now (- energy-full energy-now)))) (setq hours (/ remaining power-now))))))) - (list (cons ?c (cond ((or (> energy-full 0) (> energy-now 0)) - (number-to-string (/ energy-now voltage-now))) - (t "N/A"))) + (when (and (> energy-full 0) (> energy-now 0)) + (setq percentage-now (/ (* 100 energy-now) energy-full))) + (list (cons ?c (if (or (> energy-full 0) (> energy-now 0)) + (number-to-string (/ energy-now voltage-now)) + "N/A")) (cons ?r (if (> power-now 0.0) (format "%.1f" (/ power-now 1000000.0)) "N/A")) @@ -517,104 +584,205 @@ The following %-sequences are provided: "N/A")) (cons ?d (or temperature "N/A")) (cons ?B (or charging-state "N/A")) - (cons ?p (cond ((and (> energy-full 0) (> energy-now 0)) - (format "%.1f" - (/ (* 100 energy-now) energy-full))) - (t "N/A"))) - (cons ?L (cond - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "1" 0) - "AC") - ((battery-search-for-one-match-in-files - (list "/sys/class/power_supply/AC/online" - "/sys/class/power_supply/ACAD/online" - "/sys/class/power_supply/ADP1/online") - "0" 0) - "BAT") - (t "N/A")))))) + (cons ?b (cond ((string= charging-state "Charging") "+") + ((not percentage-now) "") + ((< percentage-now battery-load-critical) "!") + ((< percentage-now battery-load-low) "-") + (""))) + (cons ?p (if percentage-now (format "%.1f" percentage-now) "N/A")) + (cons ?L (pcase (battery-search-for-one-match-in-files + '("/sys/class/power_supply/AC/online" + "/sys/class/power_supply/ACAD/online" + "/sys/class/power_supply/ADP1/online") + (rx (in "01")) 0) + ("0" "BAT") + ("1" "AC") + (_ "N/A")))))) -(declare-function dbus-get-property "dbus.el" - (bus service path interface property)) - -;;; `upowerd' interface. -(defsubst battery-upower-prop (pname &optional device) - (dbus-get-property - :system - "org.freedesktop.UPower" - (concat "/org/freedesktop/UPower/devices/" (or device battery-upower-device)) - "org.freedesktop.UPower" - pname)) +;;; UPower interface. + +(defconst battery-upower-interface "org.freedesktop.UPower" + "Name of the UPower D-Bus interface. +See URL `https://upower.freedesktop.org/docs/UPower.html'.") + +(defconst battery-upower-path "/org/freedesktop/UPower" + "D-Bus object providing `battery-upower-interface'.") + +(defconst battery-upower-device-interface "org.freedesktop.UPower.Device" + "Name of the UPower Device D-Bus interface. +See URL `https://upower.freedesktop.org/docs/Device.html'.") + +(defconst battery-upower-device-path "/org/freedesktop/UPower/devices" + "D-Bus object providing `battery-upower-device-interface'.") + +(defvar battery--upower-signals nil + "Handles for UPower signal subscriptions.") + +(defun battery--upower-signal-handler (&rest _) + "Update battery status on receiving a UPower D-Bus signal." + (timer-event-handler battery-update-timer)) + +(defun battery--upower-props-changed (_interface changed _invalidated) + "Update status when system starts/stops running on battery. +Intended as a UPower PropertiesChanged signal handler." + (when (assoc "OnBattery" changed) + (battery--upower-signal-handler))) + +(defun battery--upower-unsubscribe () + "Unsubscribe from UPower device change signals." + (mapc #'dbus-unregister-object battery--upower-signals) + (setq battery--upower-signals ())) + +(defun battery--upower-subsribe () + "Subscribe to UPower device change signals." + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + dbus-interface-properties + "PropertiesChanged" + #'battery--upower-props-changed) + battery--upower-signals) + (dolist (method '("DeviceAdded" "DeviceRemoved")) + (push (dbus-register-signal :system battery-upower-service + battery-upower-path + battery-upower-interface + method #'battery--upower-signal-handler) + battery--upower-signals))) + +(defun battery--upower-device-properties (device) + "Return value for all available properties for the UPower DEVICE." + (dbus-get-all-properties + :system battery-upower-service + (expand-file-name device battery-upower-device-path) + battery-upower-device-interface)) + +(defun battery--upower-devices () + "List all UPower devices according to `battery-upower-device'." + (cond ((stringp battery-upower-device) + (list battery-upower-device)) + (battery-upower-device) + ((dbus-call-method :system battery-upower-service + battery-upower-path + battery-upower-interface + "EnumerateDevices")))) + +(defun battery--upower-state (props state) + "Merge the UPower battery state in PROPS with STATE. +This is an extension of the UPower DisplayDevice algorithm for +merging multiple battery states into one. PROPS is an alist of +battery properties from `battery-upower-device-interface', and +STATE is a symbol representing the state to merge with." + ;; Map UPower enum into our printable symbols. + (let* ((new (pcase (cdr (assoc "State" props)) + (1 'charging) + (2 'discharging) + (3 'empty) + (4 'fully-charged) + (5 'pending-charge) + (6 'pending-discharge))) + ;; Unknown state represented by nil. + (either (delq nil (list new state)))) + ;; Earlier states override later ones. + (car (cond ((memq 'charging either)) + ((memq 'discharging either)) + ((memq 'pending-charge either)) + ((memq 'pending-discharge either)) + ;; Only options left are full or empty, + ;; but if they conflict return nil. + ((null (cdr either)) either) + ((apply #'eq either) either))))) (defun battery-upower () - "Get battery status from dbus Upower interface. -This function works only in systems with `upowerd' daemon -running. + "Get battery status from UPower D-Bus interface. +This function works only in systems that provide a UPower D-Bus +service. The following %-sequences are provided: %c Current capacity (mWh) -%p Battery load percentage -%r Current rate -%B Battery status (verbose) +%r Current rate of charge or discharge %L AC line status (verbose) +%B Battery status (verbose) +%b Battery status: empty means high, `-' means low, + `!' means critical, and `+' means charging +%d Temperature (in degrees Celsius) +%p Battery load percentage %s Remaining time (to charge or discharge) in seconds %m Remaining time (to charge or discharge) in minutes %h Remaining time (to charge or discharge) in hours %t Remaining time (to charge or discharge) in the form `h:min'" - (let ((percents (battery-upower-prop "Percentage")) - (time-to-empty (battery-upower-prop "TimeToEmpty")) - (time-to-full (battery-upower-prop "TimeToFull")) - (state (battery-upower-prop "State")) - (online (battery-upower-prop "Online" "line_power_ACAD")) - (energy (battery-upower-prop "Energy")) - (energy-rate (battery-upower-prop "EnergyRate")) - (battery-states '((0 . "unknown") (1 . "charging") - (2 . "discharging") (3 . "empty") - (4 . "fully-charged") (5 . "pending-charge") - (6 . "pending-discharge"))) - seconds minutes hours remaining-time) - (cond ((and online time-to-full) - (setq seconds time-to-full)) - ((and (not online) time-to-empty) - (setq seconds time-to-empty))) - (when seconds - (setq minutes (/ seconds 60) - hours (/ minutes 60) - remaining-time (format "%d:%02d" hours (mod minutes 60)))) - (list (cons ?c (or (and energy - (number-to-string (round (* 1000 energy)))) - "N/A")) - (cons ?p (or (and percents (number-to-string (round percents))) - "N/A")) - (cons ?r (or (and energy-rate - (concat (number-to-string energy-rate) " W")) - "N/A")) - (cons ?B (or (and state (cdr (assoc state battery-states))) - "unknown")) - (cons ?L (or (and online "on-line") "off-line")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) - (cons ?t (or remaining-time "N/A"))))) + (let ((count 0) props type line-status state load temperature + secs mins hrs total-energy total-rate total-tte total-ttf) + ;; Merge information from all available or specified UPower + ;; devices like other `battery-status-function's. + (dolist (device (battery--upower-devices)) + (setq props (battery--upower-device-properties device)) + (setq type (cdr (assoc "Type" props))) + (cond + ((and (eq type 1) (not (eq line-status 'online))) + ;; It's a line power device: `online' if currently providing + ;; power, any other non-nil value if simply present. + (setq line-status (if (cdr (assoc "Online" props)) 'online t))) + ((and (eq type 2) (cdr (assoc "IsPresent" props))) + ;; It's a battery. + (setq count (1+ count)) + (setq state (battery--upower-state props state)) + (let ((energy (cdr (assoc "Energy" props))) + (rate (cdr (assoc "EnergyRate" props))) + (percent (cdr (assoc "Percentage" props))) + (temp (cdr (assoc "Temperature" props))) + (tte (cdr (assoc "TimeToEmpty" props))) + (ttf (cdr (assoc "TimeToFull" props)))) + (when energy (setq total-energy (+ (or total-energy 0) energy))) + (when rate (setq total-rate (+ (or total-rate 0) rate))) + (when percent (setq load (+ (or load 0) percent))) + (when temp (setq temperature (+ (or temperature 0) temp))) + (when tte (setq total-tte (+ (or total-tte 0) tte))) + (when ttf (setq total-ttf (+ (or total-ttf 0) ttf))))))) + (when (> count 1) + ;; Averages over multiple batteries. + (when load (setq load (/ load count))) + (when temperature (setq temperature (/ temperature count)))) + (when (setq secs (if (eq line-status 'online) total-ttf total-tte)) + (setq mins (/ secs 60)) + (setq hrs (/ secs 3600))) + (list (cons ?c (if total-energy + (format "%.0f" (* total-energy 1000)) + "N/A")) + (cons ?r (if total-rate (format "%.1f W" total-rate) "N/A")) + (cons ?L (cond ((eq line-status 'online) "on-line") + (line-status "off-line") + ("N/A"))) + (cons ?B (format "%s" (or state 'unknown))) + (cons ?b (cond ((eq state 'charging) "+") + ((and load (< load battery-load-critical)) "!") + ((and load (< load battery-load-low)) "-") + (""))) + ;; Zero usually means unknown. + (cons ?d (if (and temperature (/= temperature 0)) + (format "%.0f" temperature) + "N/A")) + (cons ?p (if load (format "%.0f" load) "N/A")) + (cons ?s (if secs (number-to-string secs) "N/A")) + (cons ?m (if mins (number-to-string mins) "N/A")) + (cons ?h (if hrs (number-to-string hrs) "N/A")) + (cons ?t (if hrs (format "%d:%02d" hrs (% mins 60)) "N/A"))))) ;;; `apm' interface for BSD. + (defun battery-bsd-apm () "Get APM status information from BSD apm binary. The following %-sequences are provided: +%P Advanced power saving mode state (verbose) %L AC line status (verbose) %B Battery status (verbose) %b Battery status, empty means high, `-' means low, - `!' means critical, and `+' means charging -%P Advanced power saving mode state (verbose) -%p Battery charge percentage -%s Remaining battery charge time in seconds -%m Remaining battery charge time in minutes -%h Remaining battery charge time in hours -%t Remaining battery charge time in the form `h:min'" + `!' means critical, and `+' means charging +%p Battery load percentage +%s Remaining time (to charge or discharge) in seconds +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min'" (let* ((os-name (car (split-string ;; FIXME: Can't we use something like `system-type'? (shell-command-to-string "/usr/bin/uname")))) @@ -680,7 +848,7 @@ The following %-sequences are provided: (setq seconds (string-to-number battery-life) minutes (truncate seconds 60))) (setq hours (truncate minutes 60) - remaining-time (format "%d:%02d" hours (mod minutes 60)))) + remaining-time (format "%d:%02d" hours (% minutes 60)))) (list (cons ?L (or line-status "N/A")) (cons ?B (or (car battery-status) "N/A")) (cons ?b (or (cdr battery-status) "N/A")) @@ -688,9 +856,9 @@ The following %-sequences are provided: "N/A" battery-percentage)) (cons ?P (or apm-mode "N/A")) - (cons ?s (or (and seconds (number-to-string seconds)) "N/A")) - (cons ?m (or (and minutes (number-to-string minutes)) "N/A")) - (cons ?h (or (and hours (number-to-string hours)) "N/A")) + (cons ?s (if seconds (number-to-string seconds) "N/A")) + (cons ?m (if minutes (number-to-string minutes) "N/A")) + (cons ?h (if hours (number-to-string hours) "N/A")) (cons ?t (or remaining-time "N/A"))))) @@ -705,21 +873,25 @@ The following %-sequences are provided: %b Battery status, empty means high, `-' means low, `!' means critical, and `+' means charging %p Battery load percentage -%h Remaining time in hours -%m Remaining time in minutes -%t Remaining time in the form `h:min'" - (let (power-source load-percentage battery-status battery-status-symbol - remaining-time hours minutes) +%m Remaining time (to charge or discharge) in minutes +%h Remaining time (to charge or discharge) in hours +%t Remaining time (to charge or discharge) in the form `h:min'" + (let ( power-source load-percentage battery-status battery-status-symbol + remaining-time hours minutes ) (with-temp-buffer (ignore-errors (call-process "pmset" nil t nil "-g" "ps")) (goto-char (point-min)) - (when (re-search-forward "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" nil t) + (when (re-search-forward ;; Handle old typo in output. + "\\(?:Currentl?y\\|Now\\) drawing from '\\(AC\\|Battery\\) Power'" + nil t) (setq power-source (match-string 1)) - (when (re-search-forward "^ -InternalBattery-0\\([ \t]+(id=[0-9]+)\\)*[ \t]+" nil t) + (when (re-search-forward (rx bol " -InternalBattery-0" (+ space) + (* "(id=" (+ digit) ")" (+ space))) + nil t) (when (looking-at "\\([0-9]\\{1,3\\}\\)%") (setq load-percentage (match-string 1)) (goto-char (match-end 0)) - (cond ((looking-at "; charging") + (cond ((looking-at-p "; charging") (setq battery-status "charging" battery-status-symbol "+")) ((< (string-to-number load-percentage) battery-load-critical) @@ -750,13 +922,7 @@ The following %-sequences are provided: (defun battery-format (format alist) "Substitute %-sequences in FORMAT." - (replace-regexp-in-string - "%." - (lambda (str) - (let ((char (aref str 1))) - (if (eq char ?%) "%" - (or (cdr (assoc char alist)) "")))) - format t t)) + (format-spec format alist 'delete)) (defun battery-search-for-one-match-in-files (files regexp match-num) "Search REGEXP in the content of the files listed in FILES. diff --git a/lisp/bookmark.el b/lisp/bookmark.el index e69d9f529cf..de7d60f97eb 100644 --- a/lisp/bookmark.el +++ b/lisp/bookmark.el @@ -734,8 +734,10 @@ CODING is the symbol of the coding-system in which the file is encoded." (if (memq (coding-system-base coding) '(undecided prefer-utf-8)) (setq coding 'utf-8-emacs)) (insert - (format ";;;; Emacs Bookmark Format Version %d ;;;; -*- coding: %S -*-\n" - bookmark-file-format-version (coding-system-base coding))) + (format + ";;;; Emacs Bookmark Format Version %d\ +;;;; -*- coding: %S; mode: lisp-data -*-\n" + bookmark-file-format-version (coding-system-base coding))) (insert ";;; This format is meant to be slightly human-readable;\n" ";;; nevertheless, you probably don't want to edit it.\n" ";;; " @@ -1721,7 +1723,7 @@ deletion, or > if it is flagged for displaying." ;; according to `bookmark-bookmarks-timestamp'. (defun bookmark-bmenu-set-header () "Set the immutable header line." - (let ((header (concat "%% " "Bookmark"))) + (let ((header (copy-sequence "%% Bookmark"))) (when bookmark-bmenu-toggle-filenames (setq header (concat header (make-string (- bookmark-bmenu-file-column @@ -2322,6 +2324,8 @@ strings returned are not." ;; Load Hook (defvar bookmark-load-hook nil "Hook run at the end of loading library `bookmark.el'.") +(make-obsolete-variable 'bookmark-load-hook + "use `with-eval-after-load' instead." "28.1") ;; Exit Hook, called from kill-emacs-hook (defvar bookmark-exit-hook nil diff --git a/lisp/bs.el b/lisp/bs.el index f5cb93b5169..337d22ecf83 100644 --- a/lisp/bs.el +++ b/lisp/bs.el @@ -173,7 +173,12 @@ return a string representing the column's value." (defun bs--make-header-match-string () "Return a regexp matching the first line of a Buffer Selection Menu buffer." - (concat "^\\(" (mapconcat #'car bs-attributes-list " *") " *$\\)")) + (concat "^\\(" + (apply #'concat (mapcan (lambda (e) + (and (not (equal (car e) "")) + (list " *" (car e)))) + bs-attributes-list)) + " *$\\)")) ;; Font-Lock-Settings (defvar bs-mode-font-lock-keywords diff --git a/lisp/button.el b/lisp/button.el index b3afc4eca25..d9c36a0375c 100644 --- a/lisp/button.el +++ b/lisp/button.el @@ -341,15 +341,14 @@ If the property `button-data' is present, it will later be used as the argument for the `action' callback function instead of the default argument, which is the button itself. -BEG can also be a string, in which case it is made into a button. +BEG can also be a string, in which case a copy of it is made into +a button and returned. Also see `insert-text-button'." (let ((object nil) (type-entry (or (plist-member properties 'type) (plist-member properties :type)))) - (when (stringp beg) - (setq object beg beg 0 end (length object))) ;; Disallow setting the `category' property directly. (when (plist-get properties 'category) (error "Button `category' property may not be set directly")) @@ -362,6 +361,10 @@ Also see `insert-text-button'." (setcar type-entry 'category) (setcar (cdr type-entry) (button-category-symbol (cadr type-entry)))) + (when (stringp beg) + (setq object (copy-sequence beg)) + (setq beg 0) + (setq end (length object))) ;; Now add all the text properties at once. (add-text-properties beg end ;; Each button should have a non-eq `button' @@ -469,10 +472,12 @@ return t." ;; POS is a mouse event; switch to the proper window/buffer (let ((posn (event-start pos))) (with-current-buffer (window-buffer (posn-window posn)) - (if (posn-string posn) - ;; mode-line, header-line, or display string event. - (button-activate (posn-string posn) t) - (push-button (posn-point posn) t)))) + (let* ((str (posn-string posn)) + (str-button (and str (get-text-property (cdr str) 'button (car str))))) + (if str-button + ;; mode-line, header-line, or display string event. + (button-activate str t) + (push-button (posn-point posn) t))))) ;; POS is just normal position (let ((button (button-at (or pos (point))))) (when button diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index d4562a0cc86..c5d4d0837e7 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -241,8 +241,8 @@ (calcFunc-gcd (math-neg a) b)) ((Math-looks-negp b) (calcFunc-gcd a (math-neg b))) - ((Math-zerop a) b) - ((Math-zerop b) a) + ((Math-zerop a) (math-abs b)) + ((Math-zerop b) (math-abs a)) ((and (Math-ratp a) (Math-ratp b)) (math-make-frac (math-gcd (if (eq (car-safe a) 'frac) (nth 1 a) a) diff --git a/lisp/calc/calc-mtx.el b/lisp/calc/calc-mtx.el index fe241b57c60..2850b33721b 100644 --- a/lisp/calc/calc-mtx.el +++ b/lisp/calc/calc-mtx.el @@ -275,7 +275,7 @@ in LUD decomposition." k (1+ k))) (setcar (nthcdr j (nth i lu)) sum) (let ((dum (math-lud-pivot-check sum))) - (if (Math-lessp big dum) + (if (or (math-zerop big) (Math-lessp big dum)) (setq big dum imax i))) (setq i (1+ i))) diff --git a/lisp/calc/calc.el b/lisp/calc/calc.el index 648cb7bb807..09b49621070 100644 --- a/lisp/calc/calc.el +++ b/lisp/calc/calc.el @@ -884,6 +884,8 @@ Used by `calc-user-invocation'.") (defvar calc-load-hook nil "Hook run when calc.el is loaded.") +(make-obsolete-variable 'calc-load-hook + "use `with-eval-after-load' instead." "28.1") (defvar calc-window-hook nil "Hook called to create the Calc window.") @@ -2427,7 +2429,7 @@ the United States." (if (and (memq last-command-event '(?@ ?o ?h ?\' ?m)) (string-match " " calc-hms-format)) (insert " ")) - (if (and (eq this-command last-command) + (if (and (memq last-command '(calcDigit-start calcDigit-key)) (eq last-command-event ?.)) (progn (require 'calc-ext) diff --git a/lisp/calculator.el b/lisp/calculator.el index 6996990814d..cd92f992689 100644 --- a/lisp/calculator.el +++ b/lisp/calculator.el @@ -858,13 +858,11 @@ The result should not exceed the screen width." "Convert the given STR to a number, according to the value of `calculator-input-radix'." (if calculator-input-radix - (string-to-number str (cadr (assq calculator-input-radix - '((bin 2) (oct 8) (hex 16))))) - (let* ((str (replace-regexp-in-string - "\\.\\([^0-9].*\\)?$" ".0\\1" str)) - (str (replace-regexp-in-string - "[eE][+-]?\\([^0-9].*\\)?$" "e0\\1" str))) - (string-to-number str)))) + (string-to-number str (cadr (assq calculator-input-radix + '((bin 2) (oct 8) (hex 16))))) + ;; Allow entry of "1.e3". + (let ((str (replace-regexp-in-string (rx "." (any "eE")) "e" str))) + (float (string-to-number str))))) (defun calculator-push-curnum () "Push the numeric value of the displayed number to the stack." diff --git a/lisp/calendar/cal-bahai.el b/lisp/calendar/cal-bahai.el index b6bb040dd54..4bfdf3a6cf6 100644 --- a/lisp/calendar/cal-bahai.el +++ b/lisp/calendar/cal-bahai.el @@ -57,8 +57,8 @@ (defconst calendar-bahai-month-name-array ["Bahá" "Jalál" "Jamál" "‘Aẓamat" "Núr" "Raḥmat" "Kalimát" "Kamál" - "Asmá’" "‘Izzat" "Mashíyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il" - "Sharaf" "Sulṭán" "Mulk" "‘Alá’"] + "Asmá’" "‘Izzat" "Mas͟híyyat" "‘Ilm" "Qudrat" "Qawl" "Masá’il" + "S͟haraf" "Sulṭán" "Mulk" "‘Alá’"] "Array of the month names in the Bahá’í calendar.") (defconst calendar-bahai-epoch (calendar-absolute-from-gregorian '(3 21 1844)) diff --git a/lisp/calendar/cal-julian.el b/lisp/calendar/cal-julian.el index 1c741317803..918995d0f9b 100644 --- a/lisp/calendar/cal-julian.el +++ b/lisp/calendar/cal-julian.el @@ -1,4 +1,4 @@ -;;; cal-julian.el --- calendar functions for the Julian calendar +;;; cal-julian.el --- calendar functions for the Julian calendar -*- lexical-binding:t -*- ;; Copyright (C) 1995, 1997, 2001-2020 Free Software Foundation, Inc. @@ -182,23 +182,27 @@ Echo astronomical (Julian) day number unless NOECHO is non-nil." (calendar-astro-to-absolute daynumber)))) (or noecho (calendar-astro-print-day-number))) - -;; The function below is designed to be used in sexp diary entries, -;; and may be present in users' diary files, so suppress the warning -;; about this prefix-less dynamic variable. It's called from -;; `diary-list-sexp-entries', which binds the variable. -(with-suppressed-warnings ((lexical date)) - (defvar date)) - ;;;###diary-autoload (defun diary-julian-date () "Julian calendar equivalent of date diary entry." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (format "Julian date: %s" (calendar-julian-date-string date))) ;; To be called from diary-list-sexp-entries, where DATE is bound. ;;;###diary-autoload (defun diary-astro-day-number () "Astronomical (Julian) day number diary entry." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (format "Astronomical (Julian) day number at noon UTC: %s.0" (calendar-astro-date-string date))) diff --git a/lisp/calendar/calendar.el b/lisp/calendar/calendar.el index 1ae39445680..1d5b9479e2b 100644 --- a/lisp/calendar/calendar.el +++ b/lisp/calendar/calendar.el @@ -136,14 +136,13 @@ ;; - whatever is passed to diary-remind (defmacro calendar-dlet* (binders &rest body) - "Like `let*' but using dynamic scoping." + "Like `dlet' but without warnings about non-prefixed var names." (declare (indent 1) (debug let)) - `(progn - (with-no-warnings ;Silence "lacks a prefix" warnings! - ,@(mapcar (lambda (binder) - `(defvar ,(if (consp binder) (car binder) binder))) - binders)) - (let* ,binders ,@body))) + (let ((vars (mapcar (lambda (binder) + (if (consp binder) (car binder) binder)) + binders))) + `(with-suppressed-warnings ((lexical ,@vars)) + (dlet ,binders ,@body)))) ;; Avoid recursive load of calendar when loading cal-menu. Yuck. (provide 'calendar) diff --git a/lisp/calendar/diary-lib.el b/lisp/calendar/diary-lib.el index 6d262088479..da98e44926e 100644 --- a/lisp/calendar/diary-lib.el +++ b/lisp/calendar/diary-lib.el @@ -98,7 +98,7 @@ specifies which face attribute (e.g. `:foreground') to modify, or that this is a face (`:face') to apply. TYPE is the type of attribute being applied. Available TYPES (see `diary-attrtype-convert') are: `string', `symbol', `int', `tnil', `stringtnil'." - :type '(repeat (list (string :tag "Regular expression") + :type '(repeat (list (regexp :tag "Regular expression") (integer :tag "Sub-expression") (symbol :tag "Attribute (e.g. :foreground)") (choice (const string :tag "A string") diff --git a/lisp/calendar/icalendar.el b/lisp/calendar/icalendar.el index 6847ba97496..d76c1105031 100644 --- a/lisp/calendar/icalendar.el +++ b/lisp/calendar/icalendar.el @@ -6,7 +6,7 @@ ;; Created: August 2002 ;; Keywords: calendar ;; Human-Keywords: calendar, diary, iCalendar, vCalendar -;; Version: 0.19 +;; Old-Version: 0.19 ;; This file is part of GNU Emacs. @@ -107,6 +107,7 @@ (defconst icalendar-version "0.19" "Version number of icalendar.el.") +(make-obsolete-variable 'icalendar-version nil "28.1") ;; ====================================================================== ;; Customizables diff --git a/lisp/calendar/iso8601.el b/lisp/calendar/iso8601.el index ae1dab17252..906c29b15f4 100644 --- a/lisp/calendar/iso8601.el +++ b/lisp/calendar/iso8601.el @@ -69,6 +69,8 @@ "\\([+-]?[0-9][0-9][0-9][0-9]\\)-\\([0-9][0-9]\\)") (defconst iso8601--outdated-date-match "--\\([0-9][0-9]\\)-?\\([0-9][0-9]\\)") +(defconst iso8601--outdated-reduced-precision-date-match + "---?\\([0-9][0-9]\\)") (defconst iso8601--week-date-match "\\([+-]?[0-9][0-9][0-9][0-9]\\)-?W\\([0-9][0-9]\\)-?\\([0-9]\\)?") (defconst iso8601--ordinal-date-match @@ -79,6 +81,7 @@ iso8601--full-date-match iso8601--without-day-match iso8601--outdated-date-match + iso8601--outdated-reduced-precision-date-match iso8601--week-date-match iso8601--ordinal-date-match))) @@ -136,7 +139,8 @@ See `decode-time' for the meaning of FORM." (when zone-string (setf (decoded-time-zone date) ;; The time zone in decoded times are in seconds. - (* (iso8601-parse-zone zone-string) 60))) + (* (iso8601-parse-zone zone-string) 60)) + (setf (decoded-time-dst date) nil)) date))) (defun iso8601-parse-date (string) @@ -201,6 +205,12 @@ See `decode-time' for the meaning of FORM." (iso8601--decoded-time :year year :month (decoded-time-month month-day) :day (decoded-time-day month-day)))) + ;; Obsolete format with implied year: --MM + ((iso8601--match "--\\([0-9][0-9]\\)" string) + (iso8601--decoded-time :month (string-to-number (match-string 1 string)))) + ;; Obsolete format with implied year and month: ---DD + ((iso8601--match "---\\([0-9][0-9]\\)" string) + (iso8601--decoded-time :day (string-to-number (match-string 1 string)))) (t (signal 'wrong-type-argument string)))) @@ -332,6 +342,9 @@ Return the number of minutes." (list start end (or duration ;; FIXME: Support subseconds. + ;; FIXME: It makes no sense to decode a time difference + ;; according to (decoded-time-zone end), or according to + ;; any other time zone for that matter. (decode-time (time-subtract (iso8601--encode-time end) (iso8601--encode-time start)) (or (decoded-time-zone end) 0) 'integer))))) @@ -354,7 +367,7 @@ Return the number of minutes." (iso8601--value month) (iso8601--value year) nil - dst + (if (or dst zone) dst -1) zone)) (defun iso8601--encode-time (time) diff --git a/lisp/calendar/lunar.el b/lisp/calendar/lunar.el index 616d2b0c4ed..1c0f4da0f4b 100644 --- a/lisp/calendar/lunar.el +++ b/lisp/calendar/lunar.el @@ -1,4 +1,4 @@ -;;; lunar.el --- calendar functions for phases of the moon +;;; lunar.el --- calendar functions for phases of the moon -*- lexical-binding:t -*- ;; Copyright (C) 1992-1993, 1995, 1997, 2001-2020 Free Software ;; Foundation, Inc. @@ -91,6 +91,7 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (* -0.0016528 time time) (* -0.00000239 time time time)) 360.0)) + (eclipse (eclipse-check moon-lat phase)) (adjustment (if (memq phase '(0 2)) (+ (* (- 0.1734 (* 0.000393 time)) @@ -146,7 +147,26 @@ remainder mod 4 gives the phase: 0 new moon, 1 first quarter, 2 full moon, (time (* 24 (- date (truncate date)))) (date (calendar-gregorian-from-absolute (truncate date))) (adj (dst-adjust-time date time))) - (list (car adj) (apply 'solar-time-string (cdr adj)) phase))) + (list (car adj) (apply 'solar-time-string (cdr adj)) phase eclipse))) + +;; from "Astronomy with your Personal Computer", Subroutine Eclipse +;; Line 7000 Peter Duffett-Smith Cambridge University Press 1990 +(defun eclipse-check (moon-lat phase) + (let* ((moon-lat (* (/ float-pi 180) moon-lat)) + (moon-lat (abs (- moon-lat (* (floor (/ moon-lat float-pi)) + float-pi)))) + (moon-lat (if (> moon-lat 0.37) + (- float-pi moon-lat) + moon-lat)) + (phase-name (cond ((= phase 0) "Solar") + ((= phase 2) "Lunar") + (t "")))) + (cond ((< moon-lat 2.42600766e-1) + (concat "** " phase-name " Eclipse **")) + ((< moon-lat 0.37) + (concat "** " phase-name " Eclipse possible **")) + (t + "")))) (defconst lunar-cycles-per-year 12.3685 ; 365.25/29.530588853 "Mean number of lunar cycles per 365.25 day year.") @@ -222,9 +242,10 @@ use instead of point." (insert (mapconcat (lambda (x) - (format "%s: %s %s" (calendar-date-string (car x)) + (format "%s: %s %s %s" (calendar-date-string (car x)) (lunar-phase-name (nth 2 x)) - (cadr x))) + (cadr x) + (car (last x)))) (lunar-phase-list m1 y1) "\n"))) (message "Computing phases of the moon...done")))) @@ -234,6 +255,8 @@ use instead of point." If called with an optional prefix argument ARG, prompts for month and year. This function is suitable for execution in an init file." (interactive "P") + (with-suppressed-warnings ((lexical date)) + (defvar date)) (save-excursion (let* ((date (if arg (calendar-read-date t) (calendar-current-date))) @@ -241,18 +264,17 @@ This function is suitable for execution in an init file." (displayed-year (calendar-extract-year date))) (calendar-lunar-phases)))) -;; The function below is designed to be used in sexp diary entries, -;; and may be present in users' diary files, so suppress the warning -;; about this prefix-less dynamic variable. It's called from -;; `diary-list-sexp-entries', which binds the variable. -(with-suppressed-warnings ((lexical date)) - (defvar date)) - ;;;###diary-autoload (defun diary-lunar-phases (&optional mark) "Moon phases diary entry. An optional parameter MARK specifies a face or single-character string to use when highlighting the day in the calendar." + ;; This function is designed to be used in sexp diary entries, and + ;; may be present in users' diary files, so suppress the warning + ;; about this prefix-less dynamic variable. It's called from + ;; `diary-list-sexp-entries', which binds the variable. + (with-suppressed-warnings ((lexical date)) + (defvar date)) (let* ((index (lunar-index date)) (phase (lunar-phase index))) (while (calendar-date-compare phase (list date)) diff --git a/lisp/calendar/parse-time.el b/lisp/calendar/parse-time.el index 7110a81f0de..b199fca2db5 100644 --- a/lisp/calendar/parse-time.el +++ b/lisp/calendar/parse-time.el @@ -149,62 +149,62 @@ letters, digits, plus or minus signs or colons." ;;;###autoload (defun parse-time-string (string) "Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). -STRING should be something resembling an RFC 822 (or later) date-time, e.g., -\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is +STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\", +or something resembling an RFC 822 (or later) date-time, e.g., +\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but any unknown values other than DST are returned as nil, and an unknown DST value is returned as -1." - (let ((time (list nil nil nil nil nil nil nil -1 nil)) - (temp (parse-time-tokenize (downcase string)))) - (while temp - (let ((parse-time-elt (pop temp)) - (rules parse-time-rules) - (exit nil)) - (while (and rules (not exit)) - (let* ((rule (pop rules)) - (slots (pop rule)) - (predicate (pop rule)) - (parse-time-val)) - (when (and (not (nth (car slots) time)) ;not already set - (setq parse-time-val - (cond ((and (consp predicate) - (not (functionp predicate))) - (and (numberp parse-time-elt) - (<= (car predicate) parse-time-elt) - (or (not (cdr predicate)) - (<= parse-time-elt - (cadr predicate))) - parse-time-elt)) - ((symbolp predicate) - (cdr (assoc parse-time-elt - (symbol-value predicate)))) - ((funcall predicate))))) - (setq exit t) - (while slots - (let ((new-val (if rule - (let ((this (pop rule))) - (if (vectorp this) - (cl-parse-integer - parse-time-elt - :start (aref this 0) - :end (aref this 1)) - (funcall this))) - parse-time-val))) - (setf (nth (pop slots) time) new-val)))))))) - time)) + (condition-case () + (iso8601-parse string) + (wrong-type-argument + (let ((time (list nil nil nil nil nil nil nil -1 nil)) + (temp (parse-time-tokenize (downcase string)))) + (while temp + (let ((parse-time-elt (pop temp)) + (rules parse-time-rules) + (exit nil)) + (while (and rules (not exit)) + (let* ((rule (pop rules)) + (slots (pop rule)) + (predicate (pop rule)) + (parse-time-val)) + (when (and (not (nth (car slots) time)) ;not already set + (setq parse-time-val + (cond ((and (consp predicate) + (not (functionp predicate))) + (and (numberp parse-time-elt) + (<= (car predicate) parse-time-elt) + (or (not (cdr predicate)) + (<= parse-time-elt + (cadr predicate))) + parse-time-elt)) + ((symbolp predicate) + (cdr (assoc parse-time-elt + (symbol-value predicate)))) + ((funcall predicate))))) + (setq exit t) + (while slots + (let ((new-val (if rule + (let ((this (pop rule))) + (if (vectorp this) + (cl-parse-integer + parse-time-elt + :start (aref this 0) + :end (aref this 1)) + (funcall this))) + parse-time-val))) + (setf (nth (pop slots) time) new-val)))))))) + time)))) (defun parse-iso8601-time-string (date-string) - "Parse an ISO 8601 time string, such as 2016-12-01T23:35:06-05:00. -If DATE-STRING cannot be parsed, it falls back to -`parse-time-string'." - (when-let ((time - (if (iso8601-valid-p date-string) - (decoded-time-set-defaults (iso8601-parse date-string)) - ;; Fall back to having `parse-time-string' do fancy - ;; things for us. - (parse-time-string date-string)))) + "Parse an ISO 8601 time string, such as \"2020-01-15T16:12:21-08:00\". +Fall back on parsing something resembling an RFC 822 (or later) date-time. +This function is like `parse-time-string' except that it returns +a Lisp timestamp when successful." + (when-let ((time (parse-time-string date-string))) (encode-time time))) (provide 'parse-time) diff --git a/lisp/calendar/time-date.el b/lisp/calendar/time-date.el index 1e589ece29d..eeb09926a6e 100644 --- a/lisp/calendar/time-date.el +++ b/lisp/calendar/time-date.el @@ -355,6 +355,8 @@ is output until the first non-zero unit is encountered." (defun date-days-in-month (year month) "The number of days in MONTH in YEAR." + (unless (and (numberp month) (<= 1 month 12)) + (error "Month %s is invalid" month)) (if (= month 2) (if (date-leap-year-p year) 29 @@ -515,15 +517,14 @@ TIME is modified and returned." (unless (decoded-time-year time) (setf (decoded-time-year time) 0)) - ;; When we don't have a time zone and we don't have a DST, then mark - ;; it as unknown. - (when (and (not (decoded-time-zone time)) - (not (decoded-time-dst time))) - (setf (decoded-time-dst time) -1)) + ;; When we don't have a time zone, default to DEFAULT-ZONE without + ;; DST if DEFAULT-ZONE if given, and to unknown DST otherwise. + (unless (decoded-time-zone time) + (if default-zone + (progn (setf (decoded-time-zone time) default-zone) + (setf (decoded-time-dst time) nil)) + (setf (decoded-time-dst time) -1))) - (when (and (not (decoded-time-zone time)) - default-zone) - (setf (decoded-time-zone time) 0)) time) (provide 'time-date) diff --git a/lisp/calendar/timeclock.el b/lisp/calendar/timeclock.el index f3a5d9cd60d..d12feaae8c3 100644 --- a/lisp/calendar/timeclock.el +++ b/lisp/calendar/timeclock.el @@ -193,6 +193,8 @@ to today." (defcustom timeclock-load-hook nil "Hook that gets run after timeclock has been loaded." :type 'hook) +(make-obsolete-variable 'timeclock-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom timeclock-in-hook nil "A hook run every time an \"in\" event is recorded." diff --git a/lisp/cdl.el b/lisp/cdl.el index adc05f1bb52..c8025a9f530 100644 --- a/lisp/cdl.el +++ b/lisp/cdl.el @@ -1,4 +1,4 @@ -;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs +;;; cdl.el --- Common Data Language (CDL) utility functions for GNU Emacs -*- lexical-binding: t -*- ;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/cedet/data-debug.el b/lisp/cedet/data-debug.el index 78a72dd889c..604fc40926c 100644 --- a/lisp/cedet/data-debug.el +++ b/lisp/cedet/data-debug.el @@ -49,9 +49,9 @@ ;;; Compatibility ;; -(defalias 'data-debug-overlay-properties 'overlay-properties) -(defalias 'data-debug-overlay-p 'overlayp) -(defalias 'dd-propertize 'propertize) +(define-obsolete-function-alias 'data-debug-overlay-properties 'overlay-properties "28.1") +(define-obsolete-function-alias 'data-debug-overlay-p 'overlayp "28.1") +(define-obsolete-function-alias 'dd-propertize 'propertize "28.1") ;;; GENERIC STUFF ;; @@ -73,7 +73,7 @@ The attributes belong to the tag PARENT." "Insert all the parts of OVERLAY. PREFIX specifies what to insert at the start of each line." (let ((attrprefix (concat (make-string (length prefix) ? ) "# ")) - (proplist (data-debug-overlay-properties overlay))) + (proplist (overlay-properties overlay))) (data-debug-insert-property-list proplist attrprefix) ) @@ -393,10 +393,10 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (lambda (key value) (data-debug-insert-thing key prefix - (dd-propertize "key " 'face font-lock-comment-face)) + (propertize "key " 'face font-lock-comment-face)) (data-debug-insert-thing value prefix - (dd-propertize "val " 'face font-lock-comment-face))) + (propertize "val " 'face font-lock-comment-face))) hash-table)) (defun data-debug-insert-hash-table-from-point (point) @@ -415,9 +415,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (defun data-debug-insert-hash-table-button (hash-table prefix prebuttontext) "Insert HASH-TABLE as expandable button with recursive prefix PREFIX and PREBUTTONTEXT in front of the button text." - (let ((string (dd-propertize (format "%s" hash-table) + (let ((string (propertize (format "%s" hash-table) 'face 'font-lock-keyword-face))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug hash-table 'ddebug-indent (length prefix) @@ -444,7 +444,7 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." (data-debug-insert-thing (car (cdr rest)) prefix (concat - (dd-propertize (format "%s" (car rest)) + (propertize (format "%s" (car rest)) 'face font-lock-comment-face) " : ")) (setq rest (cdr (cdr rest)))) @@ -468,9 +468,9 @@ PREBUTTONTEXT is some text between prefix and the stuff list button." A Symbol is a simple thing, but this provides some face and prefix rules. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the thing." - (let ((string (dd-propertize (format "#<WIDGET %s>" (car widget)) + (let ((string (propertize (format "#<WIDGET %s>" (car widget)) 'face 'font-lock-keyword-face))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug widget 'ddebug-indent (length prefix) @@ -613,7 +613,7 @@ PREBUTTONTEXT is some text between prefix and the stuff vector button." (symbol-value symbol) (concat (make-string indent ? ) "> ") (concat - (dd-propertize "value" + (propertize "value" 'face 'font-lock-comment-face) " "))) (data-debug-insert-property-list @@ -628,13 +628,13 @@ PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the symbol button." (let ((string (cond ((fboundp symbol) - (dd-propertize (concat "#'" (symbol-name symbol)) + (propertize (concat "#'" (symbol-name symbol)) 'face 'font-lock-function-name-face)) ((boundp symbol) - (dd-propertize (concat "'" (symbol-name symbol)) + (propertize (concat "'" (symbol-name symbol)) 'face 'font-lock-variable-name-face)) (t (format "'%s" symbol))))) - (insert (dd-propertize + (insert (propertize (concat prefix prebuttontext string) 'ddebug symbol 'ddebug-indent (length prefix) @@ -657,7 +657,7 @@ PREBUTTONTEXT is some text between prefix and the thing." (while (string-match "\t" newstr) (setq newstr (replace-match "\\t" t t newstr))) (insert prefix prebuttontext - (dd-propertize (format "\"%s\"" newstr) + (propertize (format "\"%s\"" newstr) 'face font-lock-string-face) "\n" ))) @@ -668,7 +668,7 @@ A Symbol is a simple thing, but this provides some face and prefix rules. PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between prefix and the thing." (insert prefix prebuttontext - (dd-propertize (format "%S" thing) + (propertize (format "%S" thing) 'face font-lock-string-face) "\n")) @@ -737,10 +737,10 @@ FACE is the face to use." (null . data-debug-insert-nil) ;; Overlay - (data-debug-overlay-p . data-debug-insert-overlay-button) + (overlayp . data-debug-insert-overlay-button) ;; Overlay list - ((lambda (thing) (and (consp thing) (data-debug-overlay-p (car thing)))) . + ((lambda (thing) (and (consp thing) (overlayp (car thing)))) . data-debug-insert-overlay-list-button) ;; Buffer @@ -880,7 +880,7 @@ If PARENT is non-nil, it is somehow related as a parent to thing." comment-end "" buffer-read-only t) (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (buffer-disable-undo) (set (make-local-variable 'font-lock-global-modes) nil) (font-lock-mode -1) diff --git a/lisp/cedet/ede.el b/lisp/cedet/ede.el index 1418ad9539d..41252815734 100644 --- a/lisp/cedet/ede.el +++ b/lisp/cedet/ede.el @@ -470,7 +470,7 @@ To be used in hook functions." ;; Emacs 21 has no buffer file name for directory edits. ;; so we need to add these hacks in. (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-minor-mode 1))) (define-minor-mode ede-minor-mode @@ -481,7 +481,7 @@ controlled project, then this mode is activated automatically provided `global-ede-mode' is enabled." :group 'ede (cond ((or (eq major-mode 'dired-mode) - (eq major-mode 'vc-dired-mode)) + (eq major-mode 'vc-dir-mode)) (ede-dired-minor-mode (if ede-minor-mode 1 -1))) (ede-minor-mode (if (not ede-constructing) @@ -1515,8 +1515,11 @@ It does not apply the value to buffers." (when project-dir (ede-directory-get-open-project project-dir 'ROOT)))) -(cl-defmethod project-roots ((project ede-project)) - (list (ede-project-root-directory project))) +(cl-defmethod project-root ((project ede-project)) + (ede-project-root-directory project)) + +;;; FIXME: Could someone look into implementing `project-ignores' for +;;; EDE and/or a faster `project-files'? (add-hook 'project-find-functions #'project-try-ede) @@ -1527,8 +1530,7 @@ It does not apply the value to buffers." ;; If this does not occur after the provide, we can get a recursive ;; load. Yuck! -(if (featurep 'speedbar) - (ede-speedbar-file-setup) - (add-hook 'speedbar-load-hook 'ede-speedbar-file-setup)) +(with-eval-after-load 'speedbar + (ede-speedbar-file-setup)) ;;; ede.el ends here diff --git a/lisp/cedet/ede/cpp-root.el b/lisp/cedet/ede/cpp-root.el index ee8aa5db1b7..f0dbccb7fc1 100644 --- a/lisp/cedet/ede/cpp-root.el +++ b/lisp/cedet/ede/cpp-root.el @@ -478,21 +478,6 @@ Argument COMMAND is the command to use for compiling the target." "Don't rescan this project from the sources." (message "cpp-root has nothing to rescan.")) -;;; Quick Hack -(defun ede-create-lots-of-projects-under-dir (dir projfile &rest attributes) - "Create a bunch of projects under directory DIR. -PROJFILE is a file name sans directory that indicates a subdirectory -is a project directory. -Generic ATTRIBUTES, such as :include-path can be added. -Note: This needs some work." - (let ((files (directory-files dir t))) - (dolist (F files) - (if (file-exists-p (expand-file-name projfile F)) - `(ede-cpp-root-project (file-name-nondirectory F) - :name (file-name-nondirectory F) - :file (expand-file-name projfile F) - attributes))))) - (provide 'ede/cpp-root) ;; Local variables: diff --git a/lisp/cedet/ede/pconf.el b/lisp/cedet/ede/pconf.el index 63fb62b5a57..b85b397af2d 100644 --- a/lisp/cedet/ede/pconf.el +++ b/lisp/cedet/ede/pconf.el @@ -56,8 +56,9 @@ don't do it. A value of nil means to just do it.") (and (eq ede-pconf-create-file-query 'ask) (not (eq ede-pconf-create-file-query 'never)) (not (y-or-n-p - (format "I had to create the %s file for you. Ok? " file))) - (error "Quit"))))))) + (format "I had to create the %s file for you. Ok? " + file)))) + (error "Quit")))))) (cl-defmethod ede-proj-configure-synchronize ((this ede-proj-project)) diff --git a/lisp/cedet/semantic/complete.el b/lisp/cedet/semantic/complete.el index 7abc4360f64..b262ab710f6 100644 --- a/lisp/cedet/semantic/complete.el +++ b/lisp/cedet/semantic/complete.el @@ -1635,10 +1635,10 @@ This will not happen if you directly set this variable via `setq'." :group 'semantic :version "24.3" :type 'integer - :set '(lambda (sym var) - (set-default sym var) - (when (boundp 'x-max-tooltip-size) - (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) + :set (lambda (sym var) + (set-default sym var) + (when (boundp 'x-max-tooltip-size) + (setcdr x-max-tooltip-size (max (1+ var) (cdr x-max-tooltip-size)))))) (defclass semantic-displayer-tooltip (semantic-displayer-traditional) diff --git a/lisp/cedet/semantic/db-ebrowse.el b/lisp/cedet/semantic/db-ebrowse.el index a3219af7d3e..d63e5bc4869 100644 --- a/lisp/cedet/semantic/db-ebrowse.el +++ b/lisp/cedet/semantic/db-ebrowse.el @@ -74,7 +74,7 @@ By default, include only headers since the semantic use of EBrowse is only for searching via semanticdb, and thus only headers would be searched." :group 'semanticdb - :type 'string) + :type 'regexp) ;;; SEMANTIC Database related Code ;;; Classes: @@ -181,7 +181,8 @@ is specified by `semanticdb-default-save-directory'." "Load all semanticdb controlled EBROWSE caches." (interactive) (let ((f (directory-files semanticdb-default-save-directory - t (concat semanticdb-ebrowse-default-file-name + t (concat (regexp-quote + semanticdb-ebrowse-default-file-name) "-load\\.el\\'") t))) (while f diff --git a/lisp/cedet/semantic/grammar.el b/lisp/cedet/semantic/grammar.el index 62c86f9d12d..1ed18339a72 100644 --- a/lisp/cedet/semantic/grammar.el +++ b/lisp/cedet/semantic/grammar.el @@ -1306,7 +1306,7 @@ the change bounds to encompass the whole nonterminal tag." ;; Look within the line for a ; following an even number of backslashes ;; after either a non-backslash or the line beginning. (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (set (make-local-variable 'indent-line-function) 'semantic-grammar-indent) (set (make-local-variable 'fill-paragraph-function) @@ -1663,6 +1663,42 @@ Select the buffer containing the tag's definition, and move point there." (defvar semantic-grammar-eldoc-last-data (cons nil nil)) +(defun semantic--docstring-format-sym-doc (prefix doc &optional face) + "Combine PREFIX and DOC, and shorten the result to fit in the echo area. + +When PREFIX is a symbol, propertize its symbol name with FACE +before combining it with DOC. If FACE is not provided, just +apply the nil face. + +See also: `eldoc-echo-area-use-multiline-p'." + ;; Hoisted from old `eldoc-docstring-format-sym-doc'. + ;; If the entire line cannot fit in the echo area, the symbol name may be + ;; truncated or eliminated entirely from the output to make room for the + ;; description. + (when (symbolp prefix) + (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) + (let* ((ea-multi eldoc-echo-area-use-multiline-p) + ;; Subtract 1 from window width since emacs will not write + ;; any chars to the last column, or in later versions, will + ;; cause a wraparound and resize of the echo area. + (ea-width (1- (window-width (minibuffer-window)))) + (strip (- (+ (length prefix) + (length doc)) + ea-width))) + (cond ((or (<= strip 0) + (eq ea-multi t) + (and ea-multi (> (length doc) ea-width))) + (concat prefix doc)) + ((> (length doc) ea-width) + (substring (format "%s" doc) 0 ea-width)) + ((>= strip (string-match-p ":? *\\'" prefix)) + doc) + (t + ;; Show the end of the partial symbol name, rather + ;; than the beginning, since the former is more likely + ;; to be unique given package namespace conventions. + (concat (substring prefix strip) doc))))) + (defun semantic-grammar-eldoc-get-macro-docstring (macro expander) "Return a one-line docstring for the given grammar MACRO. EXPANDER is the name of the function that expands MACRO." @@ -1681,19 +1717,18 @@ EXPANDER is the name of the function that expands MACRO." (setq doc (eldoc-function-argstring expander)))) (when doc (setq doc - (eldoc-docstring-format-sym-doc + (semantic--docstring-format-sym-doc macro (format "==> %s %s" expander doc) 'default)) (setq semantic-grammar-eldoc-last-data (cons expander doc))) doc)) ((fboundp 'elisp-get-fnsym-args-string) ;; Emacs≥25 - (elisp-get-fnsym-args-string - expander nil - (concat (propertize (symbol-name macro) + (concat (propertize (symbol-name macro) 'face 'font-lock-keyword-face) " ==> " (propertize (symbol-name macro) 'face 'font-lock-function-name-face) - ": "))))) + ": " + (elisp-get-fnsym-args-string expander nil ))))) (define-mode-local-override semantic-idle-summary-current-symbol-info semantic-grammar-mode () diff --git a/lisp/cedet/semantic/imenu.el b/lisp/cedet/semantic/imenu.el index 19e0515ac63..cdf0a23fa07 100644 --- a/lisp/cedet/semantic/imenu.el +++ b/lisp/cedet/semantic/imenu.el @@ -44,9 +44,8 @@ ;; Because semantic imenu tags will hose the current imenu handling ;; code in speedbar, force semantic/sb in. -(if (featurep 'speedbar) - (require 'semantic/sb) - (add-hook 'speedbar-load-hook (lambda () (require 'semantic/sb)))) +(with-eval-after-load 'speedbar + (require 'semantic/sb)) (defgroup semantic-imenu nil "Semantic interface to Imenu." diff --git a/lisp/cedet/semantic/wisent/comp.el b/lisp/cedet/semantic/wisent/comp.el index 4e9927f23f1..42c5756b987 100644 --- a/lisp/cedet/semantic/wisent/comp.el +++ b/lisp/cedet/semantic/wisent/comp.el @@ -3053,7 +3053,7 @@ one.") (defsubst wisent-ISVALID-TOKEN (x) "Return non-nil if X is a character or an allowed symbol." - (or (wisent-char-p x) + (or (characterp x) (wisent-ISVALID-VAR x))) (defun wisent-push-token (symbol &optional nocheck) @@ -3143,7 +3143,7 @@ the rule." (cond ((or (memq item token-list) (memq item var-list))) ;; Create new literal character token - ((wisent-char-p item) (wisent-push-token item t)) + ((characterp item) (wisent-push-token item t)) ((error "Symbol `%s' is used, but is not defined as a token and has no rules" item)))) (setq rhl (1+ rhl) diff --git a/lisp/cedet/semantic/wisent/wisent.el b/lisp/cedet/semantic/wisent/wisent.el index d8a35d3e7d3..a0a8bed1eaf 100644 --- a/lisp/cedet/semantic/wisent/wisent.el +++ b/lisp/cedet/semantic/wisent/wisent.el @@ -55,11 +55,8 @@ ;;;; Runtime stuff ;;;; ------------- -;;; Compatibility -(eval-and-compile - (if (fboundp 'char-valid-p) - (defalias 'wisent-char-p 'char-valid-p) - (defalias 'wisent-char-p 'char-or-char-int-p))) +(define-obsolete-function-alias 'wisent-char-p + #'characterp "28.1") ;;; Printed representation of terminals and nonterminals (defconst wisent-escape-sequence-strings @@ -80,7 +77,7 @@ (defsubst wisent-item-to-string (item) "Return a printed representation of ITEM. ITEM can be a nonterminal or terminal symbol, or a character literal." - (if (wisent-char-p item) + (if (characterp item) (or (cdr (assq item wisent-escape-sequence-strings)) (format "'%c'" item)) (symbol-name item))) diff --git a/lisp/cedet/srecode/document.el b/lisp/cedet/srecode/document.el index 4151b17c885..fdb44695918 100644 --- a/lisp/cedet/srecode/document.el +++ b/lisp/cedet/srecode/document.el @@ -89,7 +89,7 @@ versions of names. This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-function-alist @@ -145,7 +145,7 @@ see how best to describe what can be returned. Doesn't always work correctly, but that is just because English doesn't always work correctly." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-common-nouns-abbrevs @@ -176,7 +176,7 @@ versions of names. This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-return-first-alist @@ -193,7 +193,7 @@ This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-return-last-alist @@ -214,7 +214,7 @@ MATCH is a regexp to match in the type field. RESULT is a string, which can contain %s, which is replaced with `match-string' 1." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-param-alist @@ -234,7 +234,7 @@ RESULT is a string of text to use to describe MATCH. When one is encountered, document-insert-parameters will automatically place this comment after the parameter name." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) (defcustom srecode-document-autocomment-param-type-alist @@ -259,7 +259,7 @@ This is an alist with each element of the form: MATCH is a regexp to match in the type field. RESULT is a string." :group 'document - :type '(repeat (cons (string :tag "Regexp") + :type '(repeat (cons (regexp :tag "Regexp") (string :tag "Doc Text")))) ;;;###autoload diff --git a/lisp/cedet/srecode/semantic.el b/lisp/cedet/srecode/semantic.el index 26c14892efd..5b2dd034743 100644 --- a/lisp/cedet/srecode/semantic.el +++ b/lisp/cedet/srecode/semantic.el @@ -201,7 +201,7 @@ variable default values, and other things." (let ((tag (or srecode-semantic-selected-tag (srecode-semantic-tag-from-kill-ring)))) (when (not tag) - "No tag for current template. Use the semantic kill-ring.") + (error "No tag for current template. Use the semantic kill-ring.")) (srecode-semantic-apply-tag-to-dict (srecode-semantic-tag (semantic-tag-name tag) :prime tag) diff --git a/lisp/cedet/srecode/srt-mode.el b/lisp/cedet/srecode/srt-mode.el index 6b8c3034a4c..4c1e030fceb 100644 --- a/lisp/cedet/srecode/srt-mode.el +++ b/lisp/cedet/srecode/srt-mode.el @@ -195,7 +195,7 @@ we can tell font lock about them.") (set (make-local-variable 'comment-end) "") (set (make-local-variable 'parse-sexp-ignore-comments) t) (set (make-local-variable 'comment-start-skip) - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\);+ *") (set (make-local-variable 'font-lock-defaults) '(srecode-font-lock-keywords nil ;; perform string/comment fontification diff --git a/lisp/char-fold.el b/lisp/char-fold.el index f8a303956e3..5a3c20c7832 100644 --- a/lisp/char-fold.el +++ b/lisp/char-fold.el @@ -370,11 +370,7 @@ from which to start." (setq i (1+ i))) (when (> spaces 0) (push (char-fold--make-space-string spaces) out)) - (let ((regexp (apply #'concat (nreverse out)))) - ;; Limited by `MAX_BUF_SIZE' in `regex-emacs.c'. - (if (> (length regexp) 5000) - (regexp-quote string) - regexp)))) + (apply #'concat (nreverse out)))) ;;; Commands provided for completeness. diff --git a/lisp/cmuscheme.el b/lisp/cmuscheme.el index d590b9ecf61..d4bec95ebad 100644 --- a/lisp/cmuscheme.el +++ b/lisp/cmuscheme.el @@ -517,6 +517,8 @@ command to run." This is a good place to put keybindings." :type 'hook :group 'cmuscheme) +(make-obsolete-variable 'cmuscheme-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'cmuscheme-load-hook) diff --git a/lisp/comint.el b/lisp/comint.el index bf376a0b81c..ea06f8af87d 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -3124,7 +3124,7 @@ See `comint-word'." "\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)" "\\|{\\(?1:[^{}]+\\)}\\)" (when (memq system-type '(ms-dos windows-nt)) - "\\|%\\(?1:[^\\\\/]*\\)%") + "\\|%\\(?1:[^\\/]*\\)%") (when comint-file-name-quote-list "\\|\\\\\\(.\\)"))) (qupos nil) @@ -3641,7 +3641,7 @@ and does not normally need to be invoked by the end user or programmer." (setq-local comint-redirect-previous-input-string "") (setq mode-line-process - (if mode-line-process + (if (and mode-line-process (stringp (elt mode-line-process 0))) (list (concat (elt mode-line-process 0) " Redirection")) (list ":%s Redirection"))))) diff --git a/lisp/cus-edit.el b/lisp/cus-edit.el index 490d9055ecf..1942f25e891 100644 --- a/lisp/cus-edit.el +++ b/lisp/cus-edit.el @@ -3825,7 +3825,17 @@ Optional EVENT is the location for the menu." (defun custom-face-save (widget) "Save the face edited by WIDGET." - (custom-face-mark-to-save widget) + (let ((form (widget-get widget :custom-form))) + (if (memq form '(all lisp)) + (custom-face-mark-to-save widget) + ;; The user is working on only a selected terminal type; + ;; make sure we save the entire spec to `custom-file'. (Bug #40866) + (custom-face-edit-all widget) + (custom-face-mark-to-save widget) + (if (eq form 'selected) + (custom-face-edit-selected widget) + ;; `form' is edit or mismatch; can't happen. + (widget-put widget :custom-form form)))) (custom-save-all) (custom-face-state-set-and-redraw widget)) diff --git a/lisp/cus-face.el b/lisp/cus-face.el index ed4cf046fcf..cc766aa4509 100644 --- a/lisp/cus-face.el +++ b/lisp/cus-face.el @@ -166,9 +166,11 @@ :help-echo "Control box around text." (const :tag "Off" nil) (list :tag "Box" - :value (:line-width 2 :color "grey75" :style released-button) - (const :format "" :value :line-width) - (integer :tag "Width") + :value (:line-width (2 . 2) :color "grey75" :style released-button) + (const :format "" :value :line-width) + (cons :tag "Width" :extra-offset 2 + (integer :tag "Vertical") + (integer :tag "Horizontal")) (const :format "" :value :color) (choice :tag "Color" (const :tag "*" nil) color) (const :format "" :value :style) @@ -181,15 +183,19 @@ (and real-value (let ((lwidth (or (and (consp real-value) - (plist-get real-value :line-width)) + (if (listp (cdr real-value)) + (plist-get real-value :line-width) + real-value)) (and (integerp real-value) real-value) - 1)) + '(1 . 1))) (color (or (and (consp real-value) (plist-get real-value :color)) (and (stringp real-value) real-value) nil)) (style (and (consp real-value) (plist-get real-value :style)))) + (if (integerp lwidth) + (setq lwidth (cons (abs lwidth) lwidth))) (list :line-width lwidth :color color :style style)))) ;; filter to make customized-value suitable for storing (lambda (cus-value) diff --git a/lisp/descr-text.el b/lisp/descr-text.el index 1dbbd421489..55f0b7dcb40 100644 --- a/lisp/descr-text.el +++ b/lisp/descr-text.el @@ -763,6 +763,8 @@ The character information includes: (to (nth 4 composition)) glyph) (if (fontp font) + ;; GUI frame: show composition in terms of + ;; font glyphs and characters. (progn (insert " using this font:\n " (symbol-name (font-get font :type)) @@ -772,12 +774,25 @@ The character information includes: (while (and (<= from to) (setq glyph (lgstring-glyph gstring from))) (insert (format " %S\n" glyph)) - (setq from (1+ from)))) + (setq from (1+ from))) + (when (and (stringp (car composition)) + (string-match "\"\\([^\"]+\\)\"" (car composition))) + (insert "with these character(s):\n") + (let ((chars (match-string 1 (car composition)))) + (dotimes (i (length chars)) + (let ((char (aref chars i))) + (insert (format " %s (#x%x) %s\n" + (describe-char-padded-string char) char + (get-char-code-property + char 'name)))))))) + ;; TTY frame: show composition in terms of characters. (insert " by these characters:\n") (while (and (<= from to) (setq glyph (lgstring-glyph gstring from))) - (insert (format " %c (#x%x)\n" - (lglyph-char glyph) (lglyph-char glyph))) + (insert (format " %c (#x%x) %s\n" + (lglyph-char glyph) (lglyph-char glyph) + (get-char-code-property + (lglyph-char glyph) 'name))) (setq from (1+ from))))) (insert " by the rule:\n\t(") (let ((first t)) @@ -919,7 +934,7 @@ condition, the function may return string longer than WIDTH, see (t name))))))) ;;;###autoload -(defun describe-char-eldoc () +(defun describe-char-eldoc (_callback &rest _) "Return a description of character at point for use by ElDoc mode. Return nil if character at point is a printable ASCII @@ -929,10 +944,17 @@ Otherwise return a description formatted by of `eldoc-echo-area-use-multiline-p' variable and width of minibuffer window for width limit. -This function is meant to be used as a value of -`eldoc-documentation-function' variable." +This function can be used as a value of +`eldoc-documentation-functions' variable." (let ((ch (following-char))) (when (and (not (zerop ch)) (or (< ch 32) (> ch 127))) + ;; TODO: investigate if the new `eldoc-documentation-functions' + ;; API could significantly improve this. JT@2020-07-07: Indeed, + ;; instead of returning a string tailored here for the echo area + ;; exclusively, we could call the (now unused) argument + ;; _CALLBACK with hints on how to shorten the string if needed, + ;; or with multiple usable strings which ElDoc picks according + ;; to its space contraints. (describe-char-eldoc--format ch (unless (eq eldoc-echo-area-use-multiline-p t) diff --git a/lisp/desktop.el b/lisp/desktop.el index b15ebc9b031..7fe5f73b879 100644 --- a/lisp/desktop.el +++ b/lisp/desktop.el @@ -344,7 +344,7 @@ to the value obtained by evaluating FORM." Each element is a regular expression. Buffers with a name matched by any of these won't be deleted." :version "23.3" ; added Warnings - bug#6336 - :type '(repeat string) + :type '(repeat regexp) :group 'desktop) ;;;###autoload @@ -534,7 +534,7 @@ can guess how to load the mode's definition.") '((defining-kbd-macro nil) (isearch-mode nil) (vc-mode nil) - (vc-dired-mode nil) + (vc-dir-mode nil) (erc-track-minor-mode nil) (savehist-mode nil)) "Table mapping minor mode variables to minor mode functions. diff --git a/lisp/dframe.el b/lisp/dframe.el index 2c421470a54..efe2bc57d93 100644 --- a/lisp/dframe.el +++ b/lisp/dframe.el @@ -7,6 +7,7 @@ (defvar dframe-version "1.3" "The current version of the dedicated frame library.") +(make-obsolete-variable 'dframe-version nil "28.1") ;; This file is part of GNU Emacs. diff --git a/lisp/dired-aux.el b/lisp/dired-aux.el index 7f988540c2c..efb214088d8 100644 --- a/lisp/dired-aux.el +++ b/lisp/dired-aux.el @@ -205,7 +205,10 @@ Examples of PREDICATE: (not (and (= (file-attribute-user-id fa1) - mark files with different UID (file-attribute-user-id fa2)) (= (file-attribute-group-id fa1) - and GID. - (file-attribute-group-id fa2))))" + (file-attribute-group-id fa2)))) + +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive (list (let* ((target-dir (dired-dwim-target-directory)) @@ -409,7 +412,8 @@ has no effect on MS-Windows." (set-file-modes file (if num-modes num-modes - (file-modes-symbolic-to-number modes (file-modes file))))) + (file-modes-symbolic-to-number modes (file-modes file 'nofollow))) + 'nofollow)) (dired-do-redisplay arg))) ;;;###autoload @@ -1060,8 +1064,6 @@ corresponding command. Within CMD, %i denotes the input file(s), and %o denotes the output file. %i path(s) are relative, while %o is absolute.") -(declare-function format-spec "format-spec.el" (format specification)) - ;;;###autoload (defun dired-do-compress-to () "Compress selected files and directories to an archive. @@ -1069,7 +1071,6 @@ Prompt for the archive file name. Choose the archiving command based on the archive file-name extension and `dired-compress-files-alist'." (interactive) - (require 'format-spec) (let* ((in-files (dired-get-marked-files nil nil nil nil t)) (out-file (expand-file-name (read-file-name "Compress to: "))) (rule (cl-find-if @@ -1089,12 +1090,12 @@ and `dired-compress-files-alist'." (when (zerop (dired-shell-command (format-spec (cdr rule) - `((?\o . ,(shell-quote-argument out-file)) - (?\i . ,(mapconcat - (lambda (file-desc) - (shell-quote-argument (file-name-nondirectory - file-desc))) - in-files " ")))))) + `((?o . ,(shell-quote-argument out-file)) + (?i . ,(mapconcat + (lambda (in-file) + (shell-quote-argument + (file-name-nondirectory in-file))) + in-files " ")))))) (message (ngettext "Compressed %d file to %s" "Compressed %d files to %s" (length in-files)) @@ -3045,6 +3046,69 @@ instead." (backward-delete-char 1)) (message "%s" (buffer-string))))) + +;;; Version control from dired + +(declare-function vc-dir-unmark-all-files "vc-dir") +(declare-function vc-dir-mark-files "vc-dir") + +;;;###autoload +(defun dired-vc-next-action (verbose) + "Do the next version control operation on marked files/directories. +When only files are marked then call `vc-next-action' with the +same value of the VERBOSE argument. +When also directories are marked then call `vc-dir' and mark +the same files/directories in the VC-Dir buffer that were marked +in the Dired buffer." + (interactive "P") + (let* ((marked-files + (dired-get-marked-files nil nil nil nil t)) + (mark-files + (when (cl-some #'file-directory-p marked-files) + ;; Fix deficiency of Dired by adding slash to dirs + (mapcar (lambda (file) + (if (file-directory-p file) + (file-name-as-directory file) + file)) + marked-files)))) + (if mark-files + (let ((transient-hook (make-symbol "vc-dir-mark-files"))) + (fset transient-hook + (lambda () + (remove-hook 'vc-dir-refresh-hook transient-hook t) + (vc-dir-unmark-all-files t) + (vc-dir-mark-files mark-files))) + (vc-dir-root) + (add-hook 'vc-dir-refresh-hook transient-hook nil t)) + (vc-next-action verbose)))) + +(declare-function vc-compatible-state "vc") + +;;;###autoload +(defun dired-vc-deduce-fileset (&optional state-model-only-files not-state-changing) + (let ((backend (vc-responsible-backend default-directory)) + (files (dired-get-marked-files nil nil nil nil t)) + only-files-list + state + model) + (when (and (not not-state-changing) (cl-some #'file-directory-p files)) + (user-error "State changing VC operations on directories supported only in `vc-dir'")) + + (when state-model-only-files + (setq only-files-list (mapcar (lambda (file) (cons file (vc-state file))) files)) + (setq state (cdar only-files-list)) + ;; Check that all files are in a consistent state, since we use that + ;; state to decide which operation to perform. + (dolist (crt (cdr only-files-list)) + (unless (vc-compatible-state (cdr crt) state) + (error "When applying VC operations to multiple files, the files are required\nto be in similar VC states.\n%s in state %s clashes with %s in state %s" + (car crt) (cdr crt) (caar only-files-list) state))) + (setq only-files-list (mapcar 'car only-files-list)) + (when (and state (not (eq state 'unregistered))) + (setq model (vc-checkout-model backend only-files-list)))) + (list backend files only-files-list state model))) + + (provide 'dired-aux) ;; Local Variables: diff --git a/lisp/dired-x.el b/lisp/dired-x.el index 623a1dd3255..873d586ca1b 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -623,7 +623,9 @@ interactively, prompt for REGEXP. With prefix argument, unflag all those files. Optional fourth argument LOCALP is as in `dired-get-filename'. Optional fifth argument CASE-FOLD-P specifies the value of -`case-fold-search' used for matching REGEXP." +`case-fold-search' used for matching REGEXP. +If the region is active in Transient Mark mode, operate only on +files in the active region if `dired-mark-region' is non-nil." (interactive (list (read-regexp "Mark unmarked files matching regexp (default all): " @@ -1386,7 +1388,9 @@ present for some values of `ls-lisp-emulation'. This function operates only on the buffer content and does not refer at all to the underlying file system. Contrast this with -`find-dired', which might be preferable for the task at hand." +`find-dired', which might be preferable for the task at hand. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." ;; Using sym="" instead of nil avoids the trap of ;; (string-match "foo" sym) into which a user would soon fall. ;; Give `equal' instead of `=' in the example, as this works on diff --git a/lisp/dired.el b/lisp/dired.el index 4d0c2abdf55..1792250ac90 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -230,6 +230,8 @@ The target is used in the prompt for file copy, rename etc." You can customize key bindings or load extensions with this." :group 'dired :type 'hook) +(make-obsolete-variable 'dired-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom dired-mode-hook nil "Run at the very end of `dired-mode'." @@ -294,6 +296,36 @@ new Dired buffers." :version "26.1" :group 'dired) +(defcustom dired-mark-region 'file + "Defines what commands that mark files do with the active region. + +When nil, marking commands don't operate on all files in the +active region. They process their prefix arguments as usual. + +When the value of this option is non-nil, then all Dired commands +that mark or unmark files will operate on all files in the region +if the region is active in Transient Mark mode. + +When `file', the region marking is based on the file name. +This means don't mark the file if the end of the region is +before the file name displayed on the Dired line, so the file name +is visually outside the region. This behavior is consistent with +marking files without the region using the key `m' that advances +point to the next line after marking the file. Thus the number +of keys used to mark files is the same as the number of keys +used to select the region, e.g. `M-2 m' marks 2 files, and +`C-SPC M-2 n m' marks 2 files, and `M-2 S-down m' marks 2 files. + +When `line', the region marking is based on Dired lines, +so include the file into marking if the end of the region +is anywhere on its Dired line, except the beginning of the line." + :type '(choice + (const :tag "Don't mark files in active region" nil) + (const :tag "Exclude file name outside of region" file) + (const :tag "Include the file at region end line" line)) + :group 'dired + :version "28.1") + ;; Internal variables (defvar dired-marker-char ?* ; the answer is 42 @@ -610,12 +642,20 @@ Subexpression 2 must end right before the \\n.") PREDICATE is evaluated on each line, with point at beginning of line. MSG is a noun phrase for the type of files being marked. It should end with a noun that can be pluralized by adding `s'. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer. + Return value is the number of files marked, or nil if none were marked." - `(let ((inhibit-read-only t) count) + `(let ((inhibit-read-only t) count + (use-region-p (dired-mark--region-use-p)) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) (save-excursion (setq count 0) (when ,msg - (message "%s %ss%s..." + (message "%s %ss%s%s..." (cond ((eq dired-marker-char ?\s) "Unmarking") ((eq dired-del-marker dired-marker-char) "Flagging") @@ -623,22 +663,28 @@ Return value is the number of files marked, or nil if none were marked." ,msg (if (eq dired-del-marker dired-marker-char) " for deletion" - ""))) - (goto-char (point-min)) - (while (not (eobp)) + "") + (if use-region-p + " in region" + ""))) + (goto-char beg) + (while (< (point) end) (when ,predicate (unless (= (following-char) dired-marker-char) (delete-char 1) (insert dired-marker-char) (setq count (1+ count)))) (forward-line 1)) - (when ,msg (message "%s %s%s %s%s" + (when ,msg (message "%s %s%s %s%s%s" count ,msg (dired-plural-s count) (if (eq dired-marker-char ?\s) "un" "") (if (eq dired-marker-char dired-del-marker) - "flagged" "marked")))) + "flagged" "marked") + (if use-region-p + " in region" + "")))) (and (> count 0) count))) (defmacro dired-map-over-marks (body arg &optional show-progress @@ -757,6 +803,32 @@ ERROR can be a string with the error message." (user-error (if (stringp error) error "No files specified"))) result)) +(defun dired-mark--region-use-p () + "Whether Dired marking commands should act on region." + (and dired-mark-region + (region-active-p) + (> (region-end) (region-beginning)))) + +(defun dired-mark--region-beginning () + "Return the value of the region beginning aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-beginning)) + (line-beginning-position)) + (point-min))) + +(defun dired-mark--region-end () + "Return the value of the region end aligned to Dired file lines." + (if (dired-mark--region-use-p) + (save-excursion + (goto-char (region-end)) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))) + (point-max))) + ;; The dired command @@ -849,7 +921,6 @@ If a directory or nothing is found at point, return nil." (if (and file-name (not (file-directory-p file-name))) file-name))) -(put 'dired-mode 'grep-read-files 'dired-grep-read-files) ;;;###autoload (define-key ctl-x-map "d" 'dired) ;;;###autoload @@ -1149,15 +1220,11 @@ wildcards, erases the buffer, and builds the subdir-alist anew ;; default-directory and dired-actual-switches must be buffer-local ;; and initialized by now. - (let (dirname - ;; This makes read-in much faster. - ;; In particular, it prevents the font lock hook from running - ;; until the directory is all read in. - (inhibit-modification-hooks t)) - (if (consp dired-directory) - (setq dirname (car dired-directory)) - (setq dirname dired-directory)) - (setq dirname (expand-file-name dirname)) + (let ((dirname + (expand-file-name + (if (consp dired-directory) + (car dired-directory) + dired-directory)))) (save-excursion ;; This hook which may want to modify dired-actual-switches ;; based on dired-directory, e.g. with ange-ftp to a SysV host @@ -1167,17 +1234,25 @@ wildcards, erases the buffer, and builds the subdir-alist anew (setq buffer-undo-list nil)) (setq-local file-name-coding-system (or coding-system-for-read file-name-coding-system)) - (let ((inhibit-read-only t) - ;; Don't make undo entries for readin. - (buffer-undo-list t)) - (widen) - (erase-buffer) - (dired-readin-insert)) - (goto-char (point-min)) - ;; Must first make alist buffer local and set it to nil because - ;; dired-build-subdir-alist will call dired-clear-alist first - (setq-local dired-subdir-alist nil) - (dired-build-subdir-alist) + (widen) + ;; We used to bind `inhibit-modification-hooks' to try and speed up + ;; execution, in particular, to prevent the font-lock hook from running + ;; until the directory is all read in. + ;; It's not clear why font-lock would be a significant issue + ;; here, but I used `combine-change-calls' which should provide the + ;; same performance advantages without the problem of breaking + ;; users of after/before-change-functions. + (combine-change-calls (point-min) (point-max) + (let ((inhibit-read-only t) + ;; Don't make undo entries for readin. + (buffer-undo-list t)) + (erase-buffer) + (dired-readin-insert)) + (goto-char (point-min)) + ;; Must first make alist buffer local and set it to nil because + ;; dired-build-subdir-alist will call dired-clear-alist first + (setq-local dired-subdir-alist nil) + (dired-build-subdir-alist)) (let ((attributes (file-attributes dirname))) (if (eq (car attributes) t) (set-visited-file-modtime (file-attribute-modification-time @@ -1811,6 +1886,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." (define-key map "\177" 'dired-unmark-backward) (define-key map [remap undo] 'dired-undo) (define-key map [remap advertised-undo] 'dired-undo) + (define-key map [remap vc-next-action] 'dired-vc-next-action) ;; thumbnail manipulation (image-dired) (define-key map "\C-td" 'image-dired-display-thumbs) (define-key map "\C-tt" 'image-dired-tag-files) @@ -2149,6 +2225,7 @@ Do so according to the former subdir alist OLD-SUBDIR-ALIST." ;; Dired mode is suitable only for specially formatted data. (put 'dired-mode 'mode-class 'special) +(defvar grep-read-files-function) ;; Autoload cookie needed by desktop.el ;;;###autoload (defun dired-mode (&optional dirname switches) @@ -2210,7 +2287,6 @@ Hooks (use \\[describe-variable] to see their documentation): `dired-before-readin-hook' `dired-after-readin-hook' `dired-mode-hook' - `dired-load-hook' Keybindings: \\{dired-mode-map}" @@ -2243,6 +2319,7 @@ Keybindings: (setq-local font-lock-defaults '(dired-font-lock-keywords t nil nil beginning-of-line)) (setq-local desktop-save-buffer 'dired-desktop-buffer-misc-data) + (setq-local grep-read-files-function #'dired-grep-read-files) (setq dired-switches-alist nil) (hack-dir-local-variables-non-file-buffer) ; before sorting (dired-sort-other dired-actual-switches t) @@ -3170,8 +3247,8 @@ Any other value means to ask for each directory." (const :tag "Confirm for each top directory only" top)) :group 'dired) -;; Match anything but `.' and `..'. -(defvar dired-re-no-dot (rx (or (not ".") "..."))) +(define-obsolete-variable-alias 'dired-re-no-dot + 'directory-files-no-dot-files-regexp "28.1") ;; Delete file, possibly delete a directory and all its files. ;; This function is useful outside of dired. One could change its name @@ -3193,7 +3270,9 @@ TRASH non-nil means to trash the file instead of deleting, provided ;; but more efficient (if (not (eq t (car (file-attributes file)))) (delete-file file trash) - (let* ((empty-dir-p (null (directory-files file t dired-re-no-dot)))) + (let* ((empty-dir-p (null (directory-files + file t + directory-files-no-dot-files-regexp)))) (if (and recursive (not empty-dir-p)) (unless (eq recursive 'always) (let ((prompt @@ -3460,26 +3539,27 @@ argument or confirmation)." ;; Mark *Marked Files* window as softly-dedicated, to prevent ;; other buffers e.g. *Completions* from reusing it (bug#17554). (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window buffer - (cons 'display-buffer-below-selected - '((window-height . fit-window-to-buffer) - (preserve-size . (nil . t)))) + `(display-buffer-below-selected + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + ;; Handle (t FILE) just like (FILE), here. That value is + ;; used (only in some cases), to mean just one file that was + ;; marked, rather than the current line file. + (dired-format-columns-of-files + (if (eq (car files) t) (cdr files) files)) + (remove-text-properties (point-min) (point-max) + '(mouse-face nil help-echo nil)) + (setq tab-line-exclude nil)))) #'(lambda (window _value) (with-selected-window window (unwind-protect (apply function args) (when (window-live-p window) - (quit-restore-window window 'kill))))) - ;; Handle (t FILE) just like (FILE), here. That value is - ;; used (only in some cases), to mean just one file that was - ;; marked, rather than the current line file. - (with-current-buffer buffer - (dired-format-columns-of-files - (if (eq (car files) t) (cdr files) files)) - (remove-text-properties (point-min) (point-max) - '(mouse-face nil help-echo nil)) - (setq tab-line-exclude nil)))))) + (quit-restore-window window 'kill))))))))) (defun dired-format-columns-of-files (files) (let ((beg (point))) @@ -3578,7 +3658,8 @@ no ARGth marked file is found before this line." (defun dired-mark (arg &optional interactive) "Mark the file at point in the Dired buffer. -If the region is active, mark all files in the region. +If the region is active in Transient Mark mode, mark all files +in the region if `dired-mark-region' is non-nil. Otherwise, with a prefix arg, mark files on the next ARG lines. If on a subdir headerline, mark all its files except `.' and `..'. @@ -3589,13 +3670,20 @@ this subdir." (interactive (list current-prefix-arg t)) (cond ;; Mark files in the active region. - ((and interactive (use-region-p)) + ((and interactive dired-mark-region + (region-active-p) + (> (region-end) (region-beginning))) (save-excursion (let ((beg (region-beginning)) (end (region-end))) (dired-mark-files-in-region (progn (goto-char beg) (line-beginning-position)) - (progn (goto-char end) (line-beginning-position)))))) + (progn (goto-char end) + (if (if (eq dired-mark-region 'line) + (not (bolp)) + (get-text-property (1- (point)) 'dired-filename)) + (line-end-position) + (line-beginning-position))))))) ;; Mark subdir files from the subdir headerline. ((dired-get-subdir) (save-excursion (dired-mark-subdir-files))) @@ -3643,12 +3731,18 @@ in the active region." "Toggle marks: marked files become unmarked, and vice versa. Flagged files (indicated with flags such as `C' and `D', not with `*') are not affected, and `.' and `..' are never toggled. -As always, hidden subdirs are not affected." +As always, hidden subdirs are not affected. + +In Transient Mark mode, if the mark is active, operate on the contents +of the region if `dired-mark-region' is non-nil. Otherwise, operate +on the whole buffer." (interactive) (save-excursion - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (while (not (eobp)) + (let ((inhibit-read-only t) + (beg (dired-mark--region-beginning)) + (end (dired-mark--region-end))) + (goto-char beg) + (while (< (point) end) (or (dired-between-files) (looking-at-p dired-re-dot) ;; use subst instead of insdel because it does not move @@ -3676,6 +3770,9 @@ As always, hidden subdirs are not affected." A prefix argument means to unmark them instead. `.' and `..' are never marked. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil. + REGEXP is an Emacs regexp, not a shell wildcard. Thus, use `\\.o$' for object files--just `.o' will mark more than you might think." (interactive @@ -3727,6 +3824,9 @@ object files--just `.o' will mark more than you might think." A prefix argument means to unmark them instead. `.' and `..' are never marked. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil. + Note that if a file is visited in an Emacs buffer, and `dired-always-read-filesystem' is nil, this command will look in the buffer without revisiting the file, so the results might @@ -3771,14 +3871,18 @@ The match is against the non-directory part of the filename. Use `^' (defun dired-mark-symlinks (unflag-p) "Mark all symbolic links. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-sym) "symbolic link"))) (defun dired-mark-directories (unflag-p) "Mark all directory file lines except `.' and `..'. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (and (looking-at-p dired-re-dir) @@ -3787,7 +3891,9 @@ With prefix argument, unmark or unflag all those files." (defun dired-mark-executables (unflag-p) "Mark all executable files. -With prefix argument, unmark or unflag all those files." +With prefix argument, unmark or unflag all those files. +If the region is active in Transient Mark mode, mark files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-marker-char))) (dired-mark-if (looking-at-p dired-re-exe) "executable file"))) @@ -3797,7 +3903,9 @@ With prefix argument, unmark or unflag all those files." (defun dired-flag-auto-save-files (&optional unflag-p) "Flag for deletion files whose names suggest they are auto save files. -A prefix argument says to unmark or unflag those files instead." +A prefix argument says to unmark or unflag those files instead. +If the region is active in Transient Mark mode, flag files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if @@ -3837,7 +3945,9 @@ A prefix argument says to unmark or unflag those files instead." (defun dired-flag-backup-files (&optional unflag-p) "Flag all backup files (names ending with `~') for deletion. -With prefix argument, unmark or unflag these files." +With prefix argument, unmark or unflag these files. +If the region is active in Transient Mark mode, flag files +only in the active region if `dired-mark-region' is non-nil." (interactive "P") (let ((dired-marker-char (if unflag-p ?\s dired-del-marker))) (dired-mark-if @@ -3857,28 +3967,31 @@ With prefix argument, unmark or unflag these files." (if fn (backup-file-name-p fn)))) "backup file"))) -(defun dired-change-marks (&optional old new) +(defun dired-change-marks (old new) "Change all OLD marks to NEW marks. OLD and NEW are both characters used to mark files." + (declare (advertised-calling-convention '(old new) "28.1")) (interactive (let* ((cursor-in-echo-area t) (old (progn (message "Change (old mark): ") (read-char))) (new (progn (message "Change %c marks to (new mark): " old) (read-char)))) (list old new))) - (if (or (eq old ?\r) (eq new ?\r)) - (ding) - (let ((string (format "\n%c" old)) - (inhibit-read-only t)) - (save-excursion - (goto-char (point-min)) - (while (search-forward string nil t) - (if (if (= old ?\s) - (save-match-data - (dired-get-filename 'no-dir t)) - t) - (subst-char-in-region (match-beginning 0) - (match-end 0) old new))))))) + (dolist (c (list new old)) + (if (or (not (char-displayable-p c)) + (eq c ?\r)) + (user-error "Invalid mark character: `%c'" c))) + (let ((string (format "\n%c" old)) + (inhibit-read-only t)) + (save-excursion + (goto-char (point-min)) + (while (search-forward string nil t) + (if (if (= old ?\s) + (save-match-data + (dired-get-filename 'no-dir t)) + t) + (subst-char-in-region (match-beginning 0) + (match-end 0) old new)))))) (defun dired-unmark-all-marks () "Remove all marks from all files in the Dired buffer." diff --git a/lisp/disp-table.el b/lisp/disp-table.el index fe63573c0a3..2e88d350245 100644 --- a/lisp/disp-table.el +++ b/lisp/disp-table.el @@ -221,7 +221,7 @@ for a graphical frame." (defun make-glyph-code (char &optional face) "Return a glyph code representing char CHAR with face FACE." ;; Due to limitations on Emacs integer values, faces with - ;; face id greater that 512 are silently ignored. + ;; face id greater than 512 are silently ignored. (if (not face) char (let ((fid (face-id face))) diff --git a/lisp/dnd.el b/lisp/dnd.el index 905659e817b..1d0e26cb013 100644 --- a/lisp/dnd.el +++ b/lisp/dnd.el @@ -87,13 +87,11 @@ and is the default except for MS-Windows." (defun dnd-handle-one-url (window action url) "Handle one dropped url by calling the appropriate handler. The handler is first located by looking at `dnd-protocol-alist'. -If no match is found here, and the value of `browse-url-browser-function' -is a pair of (REGEXP . FUNCTION), those regexps are tried for a match. -If no match is found, just call `dnd-insert-text'. -WINDOW is where the drop happened, ACTION is the action for the drop, -URL is what has been dropped. -Returns ACTION." - (require 'browse-url) +If no match is found here, `browse-url-handlers' and +`browse-url-default-handlers' are searched for a match. +If no match is found, just call `dnd-insert-text'. WINDOW is +where the drop happened, ACTION is the action for the drop, URL +is what has been dropped. Returns ACTION." (let (ret) (or (catch 'done @@ -102,14 +100,13 @@ Returns ACTION." (setq ret (funcall (cdr bf) url action)) (throw 'done t))) nil) - (when (not (functionp browse-url-browser-function)) - (catch 'done - (dolist (bf browse-url-browser-function) - (when (string-match (car bf) url) - (setq ret 'private) - (funcall (cdr bf) url action) - (throw 'done t))) - nil)) + (catch 'done + (let ((browser (browse-url-select-handler url 'internal))) + (when browser + (setq ret 'private) + (funcall browser url action) + (throw 'done t))) + nil) (progn (dnd-insert-text window action url) (setq ret 'private))) diff --git a/lisp/doc-view.el b/lisp/doc-view.el index 171a939d4ec..de342f1519e 100644 --- a/lisp/doc-view.el +++ b/lisp/doc-view.el @@ -693,8 +693,6 @@ at the top edge of the page moves to the previous page." ;; time-window of loose permissions otherwise. (with-file-modes #o0700 (make-directory dir)) (file-already-exists - (when (file-symlink-p dir) - (error "Danger: %s points to a symbolic link" dir)) ;; In case it was created earlier with looser rights. ;; We could check the mode info returned by file-attributes, but it's ;; a pain to parse and it may not tell you what we want under @@ -704,7 +702,7 @@ at the top edge of the page moves to the previous page." ;; sure we have write-access to the directory and that we own it, thus ;; closing a bunch of security holes. (condition-case error - (set-file-modes dir #o0700) + (set-file-modes dir #o0700 'nofollow) (file-error (error (format "Unable to use temporary directory %s: %s" @@ -2052,8 +2050,8 @@ See the command `doc-view-mode' for more information on this mode." (when (memq (selected-frame) (alist-get 'frames attrs)) (let ((geom (alist-get 'geometry attrs))) (when geom - (setq monitor-top (nth 0 geom)) - (setq monitor-left (nth 1 geom)) + (setq monitor-left (nth 0 geom)) + (setq monitor-top (nth 1 geom)) (setq monitor-width (nth 2 geom)) (setq monitor-height (nth 3 geom)))))) (let ((frame (make-frame diff --git a/lisp/dom.el b/lisp/dom.el index 34df0e9af4c..7ff9e07b729 100644 --- a/lisp/dom.el +++ b/lisp/dom.el @@ -67,6 +67,12 @@ (setcdr old value) (setcar (cdr node) (nconc (cadr node) (list (cons attribute value))))))) +(defun dom-remove-attribute (node attribute) + "Remove ATTRIBUTE from NODE." + (setq node (dom-ensure-node node)) + (when-let ((old (assoc attribute (cadr node)))) + (setcar (cdr node) (delq old (cadr node))))) + (defmacro dom-attr (node attr) "Return the attribute ATTR from NODE. A typical attribute is `href'." diff --git a/lisp/dos-vars.el b/lisp/dos-vars.el index 0f58277fe51..47d1f83de9e 100644 --- a/lisp/dos-vars.el +++ b/lisp/dos-vars.el @@ -1,4 +1,4 @@ -;;; dos-vars.el --- MS-Dos specific user options +;;; dos-vars.el --- MS-Dos specific user options -*- lexical-binding:t -*- ;; Copyright (C) 1998, 2001-2020 Free Software Foundation, Inc. @@ -31,15 +31,13 @@ (defcustom msdos-shells '("command.com" "4dos.com" "ndos.com") "List of shells that use `/c' instead of `-c' and a backslashed command." - :type '(repeat string) - :group 'dos-fns) + :type '(repeat string)) (defcustom dos-codepage-setup-hook nil "List of functions to be called after the DOS terminal and coding systems are set up. This is the place, e.g., to set specific entries in `standard-display-table' as appropriate for your codepage, if `IT-display-table-setup' doesn't do a perfect job." - :group 'dos-fns :type '(hook) :version "20.3.3") diff --git a/lisp/elide-head.el b/lisp/elide-head.el index 57940456660..a892754d723 100644 --- a/lisp/elide-head.el +++ b/lisp/elide-head.el @@ -1,4 +1,4 @@ -;;; elide-head.el --- hide headers in files +;;; elide-head.el --- hide headers in files -*- lexical-binding: t; -*- ;; Copyright (C) 1999, 2001-2020 Free Software Foundation, Inc. @@ -63,12 +63,10 @@ The cars of elements of the list are searched for in order. Text is elided with an invisible overlay from the end of the line where the first match is found to the end of the match for the corresponding cdr." - :group 'elide-head - :type '(alist :key-type (string :tag "Start regexp") - :value-type (string :tag "End regexp"))) + :type '(alist :key-type (regexp :tag "Start regexp") + :value-type (regexp :tag "End regexp"))) -(defvar elide-head-overlay nil) -(make-variable-buffer-local 'elide-head-overlay) +(defvar-local elide-head-overlay nil) ;;;###autoload (defun elide-head (&optional arg) @@ -108,7 +106,7 @@ This is suitable as an entry on `find-file-hook' or appropriate mode hooks." (overlay-put elide-head-overlay 'after-string "..."))))))) (defun elide-head-show () - "Show a header elided current buffer by \\[elide-head]." + "Show a header in the current buffer elided by \\[elide-head]." (interactive) (if (and (overlayp elide-head-overlay) (overlay-buffer elide-head-overlay)) diff --git a/lisp/emacs-lisp/autoload.el b/lisp/emacs-lisp/autoload.el index dc7461d93ee..ede4edcd57e 100644 --- a/lisp/emacs-lisp/autoload.el +++ b/lisp/emacs-lisp/autoload.el @@ -895,7 +895,7 @@ FILE's modification time." (cons (lambda () (ignore-errors (delete-file tempfile))) kill-emacs-hook))) (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes)) + (set-file-modes tempfile desired-modes 'nofollow)) (write-region (point-min) (point-max) tempfile nil 1) (backup-buffer) (rename-file tempfile buffer-file-name t)) diff --git a/lisp/emacs-lisp/benchmark.el b/lisp/emacs-lisp/benchmark.el index a7fcc5cb8f2..2fa5a878801 100644 --- a/lisp/emacs-lisp/benchmark.el +++ b/lisp/emacs-lisp/benchmark.el @@ -81,7 +81,7 @@ result. The overhead of the `lambda's is accounted for." (gcs (make-symbol "gcs")) (gc (make-symbol "gc")) (code (byte-compile `(lambda () ,@forms))) - (lambda-code (byte-compile '(lambda ())))) + (lambda-code (byte-compile '(lambda ())))) `(let ((,gc gc-elapsed) (,gcs gcs-done)) (list ,(if (or (symbolp repetitions) (> repetitions 1)) diff --git a/lisp/emacs-lisp/bindat.el b/lisp/emacs-lisp/bindat.el index 850af93571f..d168c255121 100644 --- a/lisp/emacs-lisp/bindat.el +++ b/lisp/emacs-lisp/bindat.el @@ -149,9 +149,6 @@ ;; | ip -- 4 byte vector ;; | bits LEN -- List with bits set in LEN bytes. ;; -;; -- Note: 32 bit values may be limited by emacs' INTEGER -;; implementation limits. -;; ;; -- Example: `bits 2' will unpack 0x28 0x1c to (2 3 4 11 13) ;; and 0x1c 0x28 to (3 5 10 11 12). @@ -635,7 +632,7 @@ If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%d" (if (stringp sep) sep "."))) (defun bindat-vector-to-hex (vect &optional sep) - "Format vector VECT in hex format separated by dots. + "Format vector VECT in hex format separated by colons. If optional second arg SEP is a string, use that as separator." (bindat-format-vector vect "%02x" (if (stringp sep) sep ":"))) diff --git a/lisp/emacs-lisp/byte-opt.el b/lisp/emacs-lisp/byte-opt.el index 90ab8911c39..48efff911f7 100644 --- a/lisp/emacs-lisp/byte-opt.el +++ b/lisp/emacs-lisp/byte-opt.el @@ -391,13 +391,6 @@ (and (nth 1 form) (not for-effect) form)) - ((eq (car-safe fn) 'lambda) - (let ((newform (byte-compile-unfold-lambda form))) - (if (eq newform form) - ;; Some error occurred, avoid infinite recursion - form - (byte-optimize-form-code-walker newform for-effect)))) - ((eq (car-safe fn) 'closure) form) ((memq fn '(let let*)) ;; recursively enter the optimizer for the bindings and body ;; of a let or let*. This for depth-firstness: forms that @@ -444,13 +437,6 @@ ;; will be optimized away in the lap-optimize pass. (cons fn (byte-optimize-body (cdr form) for-effect))) - ((eq fn 'with-output-to-temp-buffer) - ;; this is just like the above, except for the first argument. - (cons fn - (cons - (byte-optimize-form (nth 1 form) nil) - (byte-optimize-body (cdr (cdr form)) for-effect)))) - ((eq fn 'if) (when (< (length form) 3) (byte-compile-warn "too few arguments for `if'")) @@ -480,6 +466,13 @@ backwards))))) (cons fn (mapcar 'byte-optimize-form (cdr form))))) + ((eq fn 'while) + (unless (consp (cdr form)) + (byte-compile-warn "too few arguments for `while'")) + (cons fn + (cons (byte-optimize-form (cadr form) nil) + (byte-optimize-body (cddr form) t)))) + ((eq fn 'interactive) (byte-compile-warn "misplaced interactive spec: `%s'" (prin1-to-string form)) @@ -491,15 +484,12 @@ form) ((eq fn 'condition-case) - (if byte-compile--use-old-handlers - ;; Will be optimized later. - form - `(condition-case ,(nth 1 form) ;Not evaluated. - ,(byte-optimize-form (nth 2 form) for-effect) - ,@(mapcar (lambda (clause) - `(,(car clause) - ,@(byte-optimize-body (cdr clause) for-effect))) - (nthcdr 3 form))))) + `(condition-case ,(nth 1 form) ;Not evaluated. + ,(byte-optimize-form (nth 2 form) for-effect) + ,@(mapcar (lambda (clause) + `(,(car clause) + ,@(byte-optimize-body (cdr clause) for-effect))) + (nthcdr 3 form)))) ((eq fn 'unwind-protect) ;; the "protected" part of an unwind-protect is compiled (and thus @@ -514,12 +504,7 @@ ((eq fn 'catch) (cons fn (cons (byte-optimize-form (nth 1 form) nil) - (if byte-compile--use-old-handlers - ;; The body of a catch is compiled (and thus - ;; optimized) as a top-level form, so don't do it - ;; here. - (cdr (cdr form)) - (byte-optimize-body (cdr form) for-effect))))) + (byte-optimize-body (cdr form) for-effect)))) ((eq fn 'ignore) ;; Don't treat the args to `ignore' as being @@ -531,6 +516,15 @@ ;; Needed as long as we run byte-optimize-form after cconv. ((eq fn 'internal-make-closure) form) + ((eq (car-safe fn) 'lambda) + (let ((newform (byte-compile-unfold-lambda form))) + (if (eq newform form) + ;; Some error occurred, avoid infinite recursion + form + (byte-optimize-form-code-walker newform for-effect)))) + + ((eq (car-safe fn) 'closure) form) + ((byte-code-function-p fn) (cons fn (mapcar #'byte-optimize-form (cdr form)))) @@ -558,7 +552,10 @@ (let ((args (mapcar #'byte-optimize-form (cdr form)))) (if (and (get fn 'pure) (byte-optimize-all-constp args)) - (list 'quote (apply fn (mapcar #'eval args))) + (let ((arg-values (mapcar #'eval args))) + (condition-case nil + (list 'quote (apply fn arg-values)) + (error (cons fn args)))) (cons fn args))))))) (defun byte-optimize-all-constp (list) @@ -673,36 +670,18 @@ (apply (car form) constants)) form))) -;; Portable Emacs integers fall in this range. -(defconst byte-opt--portable-max #x1fffffff) -(defconst byte-opt--portable-min (- -1 byte-opt--portable-max)) - -;; True if N is a number that works the same on all Emacs platforms. -;; Portable Emacs fixnums are exactly representable as floats on all -;; Emacs platforms, and (except for -0.0) any floating-point number -;; that equals one of these integers must be the same on all -;; platforms. Although other floating-point numbers such as 0.5 are -;; also portable, it can be tricky to characterize them portably so -;; they are not optimized. -(defun byte-opt--portable-numberp (n) - (and (numberp n) - (<= byte-opt--portable-min n byte-opt--portable-max) - (= n (floor n)) - (not (and (floatp n) (zerop n) - (condition-case () (< (/ n) 0) (error)))))) - -;; Use OP to reduce any leading prefix of portable numbers in the list -;; (cons ACCUM ARGS) down to a single portable number, and return the +;; Use OP to reduce any leading prefix of constant numbers in the list +;; (cons ACCUM ARGS) down to a single number, and return the ;; resulting list A of arguments. The idea is that applying OP to A ;; is equivalent to (but likely more efficient than) applying OP to ;; (cons ACCUM ARGS), on any Emacs platform. Do not make any special ;; provision for (- X) or (/ X); for example, it is the caller’s ;; responsibility that (- 1 0) should not be "optimized" to (- 1). (defun byte-opt--arith-reduce (op accum args) - (when (byte-opt--portable-numberp accum) + (when (numberp accum) (let (accum1) - (while (and (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp + (while (and (numberp (car args)) + (numberp (setq accum1 (condition-case () (funcall op accum (car args)) (error)))) @@ -725,6 +704,9 @@ (integer (if integer-is-first arg1 arg2)) (other (if integer-is-first arg2 arg1))) (list (if (eq integer 1) '1+ '1-) other))) + ;; (+ x y z) -> (+ (+ x y) z) + ((= (length args) 3) + `(+ ,(byte-optimize-plus `(+ ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '+ args))))) @@ -747,13 +729,15 @@ ;; (- x -1) --> (1+ x) ((equal (cdr args) '(-1)) (list '1+ (car args))) - ;; (- n) -> -n, where n and -n are portable numbers. + ;; (- n) -> -n, where n and -n are constant numbers. ;; This must be done separately since byte-opt--arith-reduce ;; is not applied to (- n). ((and (null (cdr args)) - (byte-opt--portable-numberp (car args)) - (byte-opt--portable-numberp (- (car args)))) + (numberp (car args))) (- (car args))) + ;; (- x y z) -> (- (- x y) z) + ((= (length args) 3) + `(- ,(byte-optimize-minus `(- ,(car args) ,(cadr args))) ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '- args)))))) @@ -762,8 +746,7 @@ (let ((args (cdr form))) (when (null (cdr args)) (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1+ n))) + (when (numberp n) (setq form (1+ n)))))) form) @@ -771,8 +754,7 @@ (let ((args (cdr form))) (when (null (cdr args)) (let ((n (car args))) - (when (and (byte-opt--portable-numberp n) - (byte-opt--portable-numberp (1- n))) + (when (numberp n) (setq form (1- n)))))) form) @@ -783,6 +765,10 @@ ((null args) 1) ;; (* n) -> n, where n is a number ((and (null (cdr args)) (numberp (car args))) (car args)) + ;; (* x y z) -> (* (* x y) z) + ((= (length args) 3) + `(* ,(byte-optimize-multiply `(* ,(car args) ,(cadr args))) + ,@(cddr args))) ;; not further optimized ((equal args (cdr form)) form) (t (cons '* args))))) @@ -814,7 +800,7 @@ (t ;; This can enable some lapcode optimizations. (list (car form) (nth 2 form) (nth 1 form))))) -(defun byte-optimize-predicate (form) +(defun byte-optimize-constant-args (form) (let ((ok t) (rest (cdr form))) (while (and rest ok) @@ -829,9 +815,6 @@ (defun byte-optimize-identity (form) (if (and (cdr form) (null (cdr (cdr form)))) (nth 1 form) - (byte-compile-warn "identity called with %d arg%s, but requires 1" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) form)) (defun byte-optimize--constant-symbol-p (expr) @@ -864,21 +847,27 @@ ;; Arity errors reported elsewhere. form)) +(defun byte-optimize-assoc (form) + ;; Replace 2-argument `assoc' with `assq', `rassoc' with `rassq', + ;; if the first arg is a symbol. + (if (and (= (length form) 3) + (byte-optimize--constant-symbol-p (nth 1 form))) + (cons (if (eq (car form) 'assoc) 'assq 'rassq) + (cdr form)) + form)) + (defun byte-optimize-memq (form) ;; (memq foo '(bar)) => (and (eq foo 'bar) '(bar)) - (if (/= (length (cdr form)) 2) - (byte-compile-warn "memq called with %d arg%s, but requires 2" - (length (cdr form)) - (if (= 1 (length (cdr form))) "" "s")) - (let ((list (nth 2 form))) - (when (and (eq (car-safe list) 'quote) + (if (= (length (cdr form)) 2) + (let ((list (nth 2 form))) + (if (and (eq (car-safe list) 'quote) (listp (setq list (cadr list))) (= (length list) 1)) - (setq form (byte-optimize-and - `(and ,(byte-optimize-predicate - `(eq ,(nth 1 form) ',(nth 0 list))) - ',list))))) - (byte-optimize-predicate form))) + `(and (eq ,(nth 1 form) ',(nth 0 list)) + ',list) + form)) + ;; Arity errors reported elsewhere. + form)) (defun byte-optimize-concat (form) "Merge adjacent constant arguments to `concat'." @@ -911,6 +900,8 @@ (put 'memq 'byte-optimizer 'byte-optimize-memq) (put 'memql 'byte-optimizer 'byte-optimize-member) (put 'member 'byte-optimizer 'byte-optimize-member) +(put 'assoc 'byte-optimizer 'byte-optimize-assoc) +(put 'rassoc 'byte-optimizer 'byte-optimize-assoc) (put '+ 'byte-optimizer 'byte-optimize-plus) (put '* 'byte-optimizer 'byte-optimize-multiply) @@ -926,31 +917,8 @@ (put 'string= 'byte-optimizer 'byte-optimize-binary-predicate) (put 'string-equal 'byte-optimizer 'byte-optimize-binary-predicate) -(put '< 'byte-optimizer 'byte-optimize-predicate) -(put '> 'byte-optimizer 'byte-optimize-predicate) -(put '<= 'byte-optimizer 'byte-optimize-predicate) -(put '>= 'byte-optimizer 'byte-optimize-predicate) (put '1+ 'byte-optimizer 'byte-optimize-1+) (put '1- 'byte-optimizer 'byte-optimize-1-) -(put 'not 'byte-optimizer 'byte-optimize-predicate) -(put 'null 'byte-optimizer 'byte-optimize-predicate) -(put 'consp 'byte-optimizer 'byte-optimize-predicate) -(put 'listp 'byte-optimizer 'byte-optimize-predicate) -(put 'symbolp 'byte-optimizer 'byte-optimize-predicate) -(put 'stringp 'byte-optimizer 'byte-optimize-predicate) -(put 'string< 'byte-optimizer 'byte-optimize-predicate) -(put 'string-lessp 'byte-optimizer 'byte-optimize-predicate) -(put 'proper-list-p 'byte-optimizer 'byte-optimize-predicate) - -(put 'logand 'byte-optimizer 'byte-optimize-predicate) -(put 'logior 'byte-optimizer 'byte-optimize-predicate) -(put 'logxor 'byte-optimizer 'byte-optimize-predicate) -(put 'lognot 'byte-optimizer 'byte-optimize-predicate) - -(put 'car 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr 'byte-optimizer 'byte-optimize-predicate) -(put 'car-safe 'byte-optimizer 'byte-optimize-predicate) -(put 'cdr-safe 'byte-optimizer 'byte-optimize-predicate) (put 'concat 'byte-optimizer 'byte-optimize-concat) @@ -981,7 +949,7 @@ nil)) ((null (cdr (cdr form))) (nth 1 form)) - ((byte-optimize-predicate form)))) + ((byte-optimize-constant-args form)))) (defun byte-optimize-or (form) ;; Throw away nil's, and simplify if less than 2 args. @@ -994,7 +962,7 @@ (setq form (copy-sequence form) rest (setcdr (memq (car rest) form) nil)))) (if (cdr (cdr form)) - (byte-optimize-predicate form) + (byte-optimize-constant-args form) (nth 1 form)))) (defun byte-optimize-cond (form) @@ -1141,7 +1109,7 @@ (list 'car (if (zerop (nth 1 form)) (nth 2 form) (list 'cdr (nth 2 form)))) - (byte-optimize-predicate form)) + form) form)) (put 'nthcdr 'byte-optimizer 'byte-optimize-nthcdr) @@ -1153,7 +1121,7 @@ (while (>= (setq count (1- count)) 0) (setq form (list 'cdr form))) form) - (byte-optimize-predicate form)) + form) form)) ;; Fixme: delete-char -> delete-region (byte-coded) @@ -1220,8 +1188,8 @@ length line-beginning-position line-end-position local-variable-if-set-p local-variable-p locale-info log log10 logand logb logcount logior lognot logxor lsh - make-list make-string make-symbol marker-buffer max member memq min - minibuffer-selected-window minibuffer-window + make-byte-code make-list make-string make-symbol marker-buffer max + member memq min minibuffer-selected-window minibuffer-window mod multibyte-char-to-unibyte next-window nth nthcdr number-to-string parse-colon-path plist-get plist-member prefix-numeric-value previous-window prin1-to-string propertize @@ -1296,9 +1264,9 @@ ;; Pure functions are side-effect free functions whose values depend ;; only on their arguments, not on the platform. For these functions, ;; calls with constant arguments can be evaluated at compile time. -;; This may shift runtime errors to compile time. For example, logand -;; is pure since its results are machine-independent, whereas ash is -;; not pure because (ash 1 29)'s value depends on machine word size. +;; For example, ash is pure since its results are machine-independent, +;; whereas lsh is not pure because (lsh -1 -1)'s value depends on the +;; fixnum range. ;; ;; When deciding whether a function is pure, do not worry about ;; mutable strings or markers, as they are so unlikely in real code @@ -1308,9 +1276,41 @@ ;; values if a marker is moved. (let ((pure-fns - '(% concat logand logcount logior lognot logxor - regexp-opt regexp-quote - string-to-char string-to-syntax symbol-name))) + '(concat regexp-opt regexp-quote + string-to-char string-to-syntax symbol-name + eq eql + = /= < <= => > min max + + - * / % mod abs ash 1+ 1- sqrt + logand logior lognot logxor logcount + copysign isnan ldexp float logb + floor ceiling round truncate + ffloor fceiling fround ftruncate + string= string-equal string< string-lessp + consp atom listp nlistp propert-list-p + sequencep arrayp vectorp stringp bool-vector-p hash-table-p + null not + numberp integerp floatp natnump characterp + integer-or-marker-p number-or-marker-p char-or-string-p + symbolp keywordp + type-of + identity ignore + + ;; The following functions are pure up to mutation of their + ;; arguments. This is pure enough for the purposes of + ;; constant folding, but not necessarily for all kinds of + ;; code motion. + car cdr car-safe cdr-safe nth nthcdr last + equal + length safe-length + memq memql member + ;; `assoc' and `assoc-default' are excluded since they are + ;; impure if the test function is (consider `string-match'). + assq rassq rassoc + plist-get lax-plist-get plist-member + aref elt + bool-vector-subsetp + bool-vector-count-population bool-vector-count-consecutive + ))) (while pure-fns (put (car pure-fns) 'pure t) (setq pure-fns (cdr pure-fns))) @@ -1510,13 +1510,13 @@ byte-current-buffer byte-stack-ref)) (defconst byte-compile-side-effect-free-ops - (nconc + (append '(byte-varref byte-nth byte-memq byte-car byte-cdr byte-length byte-aref byte-symbol-value byte-get byte-concat2 byte-concat3 byte-sub1 byte-add1 byte-eqlsign byte-gtr byte-lss byte-leq byte-geq byte-diff byte-negate byte-plus byte-max byte-min byte-mult byte-char-after byte-char-syntax byte-buffer-substring byte-string= byte-string< byte-nthcdr byte-elt - byte-member byte-assq byte-quo byte-rem) + byte-member byte-assq byte-quo byte-rem byte-substring) byte-compile-side-effect-and-error-free-ops)) ;; This crock is because of the way DEFVAR_BOOL variables work. @@ -2195,7 +2195,7 @@ If FOR-EFFECT is non-nil, the return value is assumed to be of no importance." (or noninteractive (message "compiling %s...done" x))) '(byte-optimize-form byte-optimize-body - byte-optimize-predicate + byte-optimize-constant-args byte-optimize-binary-predicate ;; Inserted some more than necessary, to speed it up. byte-optimize-form-code-walker diff --git a/lisp/emacs-lisp/byte-run.el b/lisp/emacs-lisp/byte-run.el index 70fe06085dc..88e21b73fed 100644 --- a/lisp/emacs-lisp/byte-run.el +++ b/lisp/emacs-lisp/byte-run.el @@ -82,65 +82,84 @@ The return value of this function is not used." ;; We define macro-declaration-alist here because it is needed to ;; handle declarations in macro definitions and this is the first file -;; loaded by loadup.el that uses declarations in macros. +;; loaded by loadup.el that uses declarations in macros. We specify +;; the values as named aliases so that `describe-variable' prints +;; something useful; cf. Bug#40491. We can only use backquotes inside +;; the lambdas and not for those properties that are used by functions +;; loaded before backquote.el. + +(defalias 'byte-run--set-advertised-calling-convention + #'(lambda (f _args arglist when) + (list 'set-advertised-calling-convention + (list 'quote f) (list 'quote arglist) (list 'quote when)))) + +(defalias 'byte-run--set-obsolete + #'(lambda (f _args new-name when) + (list 'make-obsolete + (list 'quote f) (list 'quote new-name) (list 'quote when)))) + +(defalias 'byte-run--set-interactive-only + #'(lambda (f _args instead) + (list 'function-put (list 'quote f) + ''interactive-only (list 'quote instead)))) + +(defalias 'byte-run--set-pure + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''pure (list 'quote val)))) + +(defalias 'byte-run--set-side-effect-free + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''side-effect-free (list 'quote val)))) + +(defalias 'byte-run--set-compiler-macro + #'(lambda (f args compiler-function) + (if (not (eq (car-safe compiler-function) 'lambda)) + `(eval-and-compile + (function-put ',f 'compiler-macro #',compiler-function)) + (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) + ;; Avoid cadr/cddr so we can use `compiler-macro' before + ;; defining cadr/cddr. + (data (cdr compiler-function))) + `(progn + (eval-and-compile + (function-put ',f 'compiler-macro #',cfname)) + ;; Don't autoload the compiler-macro itself, since the + ;; macroexpander will find this file via `f's autoload, + ;; if needed. + :autoload-end + (eval-and-compile + (defun ,cfname (,@(car data) ,@args) + ,@(cdr data)))))))) + +(defalias 'byte-run--set-doc-string + #'(lambda (f _args pos) + (list 'function-put (list 'quote f) + ''doc-string-elt (list 'quote pos)))) + +(defalias 'byte-run--set-indent + #'(lambda (f _args val) + (list 'function-put (list 'quote f) + ''lisp-indent-function (list 'quote val)))) ;; Add any new entries to info node `(elisp)Declare Form'. (defvar defun-declarations-alist (list - ;; We can only use backquotes inside the lambdas and not for those - ;; properties that are used by functions loaded before backquote.el. (list 'advertised-calling-convention - #'(lambda (f _args arglist when) - (list 'set-advertised-calling-convention - (list 'quote f) (list 'quote arglist) (list 'quote when)))) - (list 'obsolete - #'(lambda (f _args new-name when) - (list 'make-obsolete - (list 'quote f) (list 'quote new-name) (list 'quote when)))) - (list 'interactive-only - #'(lambda (f _args instead) - (list 'function-put (list 'quote f) - ''interactive-only (list 'quote instead)))) + #'byte-run--set-advertised-calling-convention) + (list 'obsolete #'byte-run--set-obsolete) + (list 'interactive-only #'byte-run--set-interactive-only) ;; FIXME: Merge `pure' and `side-effect-free'. - (list 'pure - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''pure (list 'quote val))) + (list 'pure #'byte-run--set-pure "If non-nil, the compiler can replace calls with their return value. This may shift errors from run-time to compile-time.") - (list 'side-effect-free - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''side-effect-free (list 'quote val))) + (list 'side-effect-free #'byte-run--set-side-effect-free "If non-nil, calls can be ignored if their value is unused. If `error-free', drop calls even if `byte-compile-delete-errors' is nil.") - (list 'compiler-macro - #'(lambda (f args compiler-function) - (if (not (eq (car-safe compiler-function) 'lambda)) - `(eval-and-compile - (function-put ',f 'compiler-macro #',compiler-function)) - (let ((cfname (intern (concat (symbol-name f) "--anon-cmacro"))) - ;; Avoid cadr/cddr so we can use `compiler-macro' before - ;; defining cadr/cddr. - (data (cdr compiler-function))) - `(progn - (eval-and-compile - (function-put ',f 'compiler-macro #',cfname)) - ;; Don't autoload the compiler-macro itself, since the - ;; macroexpander will find this file via `f's autoload, - ;; if needed. - :autoload-end - (eval-and-compile - (defun ,cfname (,@(car data) ,@args) - ,@(cdr data)))))))) - (list 'doc-string - #'(lambda (f _args pos) - (list 'function-put (list 'quote f) - ''doc-string-elt (list 'quote pos)))) - (list 'indent - #'(lambda (f _args val) - (list 'function-put (list 'quote f) - ''lisp-indent-function (list 'quote val))))) + (list 'compiler-macro #'byte-run--set-compiler-macro) + (list 'doc-string #'byte-run--set-doc-string) + (list 'indent #'byte-run--set-indent)) "List associating function properties to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. For each (PROP . VALUES) in a function's declaration, @@ -150,18 +169,22 @@ to set this property. This is used by `declare'.") +(defalias 'byte-run--set-debug + #'(lambda (name _args spec) + (list 'progn :autoload-end + (list 'put (list 'quote name) + ''edebug-form-spec (list 'quote spec))))) + +(defalias 'byte-run--set-no-font-lock-keyword + #'(lambda (name _args val) + (list 'function-put (list 'quote name) + ''no-font-lock-keyword (list 'quote val)))) + (defvar macro-declarations-alist (cons - (list 'debug - #'(lambda (name _args spec) - (list 'progn :autoload-end - (list 'put (list 'quote name) - ''edebug-form-spec (list 'quote spec))))) + (list 'debug #'byte-run--set-debug) (cons - (list 'no-font-lock-keyword - #'(lambda (name _args val) - (list 'function-put (list 'quote name) - ''no-font-lock-keyword (list 'quote val)))) + (list 'no-font-lock-keyword #'byte-run--set-no-font-lock-keyword) defun-declarations-alist)) "List associating properties of macros to their macro expansion. Each element of the list takes the form (PROP FUN) where FUN is a function. diff --git a/lisp/emacs-lisp/bytecomp.el b/lisp/emacs-lisp/bytecomp.el index 5479e6536a3..22e648e44ba 100644 --- a/lisp/emacs-lisp/bytecomp.el +++ b/lisp/emacs-lisp/bytecomp.el @@ -719,14 +719,15 @@ otherwise pop it") "to make a binding to record entire window configuration") (byte-defop 140 0 byte-save-restriction "to make a binding to record the current buffer clipping restrictions") -(byte-defop 141 -1 byte-catch +(byte-defop 141 -1 byte-catch-OBSOLETE ; Not generated since Emacs 25. "for catch. Takes, on stack, the tag and an expression for the body") (byte-defop 142 -1 byte-unwind-protect "for unwind-protect. Takes, on stack, an expression for the unwind-action") ;; For condition-case. Takes, on stack, the variable to bind, ;; an expression for the body, and a list of clauses. -(byte-defop 143 -2 byte-condition-case) +;; Not generated since Emacs 25. +(byte-defop 143 -2 byte-condition-case-OBSOLETE) (byte-defop 144 0 byte-temp-output-buffer-setup-OBSOLETE) (byte-defop 145 -1 byte-temp-output-buffer-show-OBSOLETE) @@ -1201,7 +1202,7 @@ message buffer `default-directory'." byte-compile-last-warned-form)))) (insert (format "\nIn %s:\n" form))) (when level - (insert (format "%s%s" file pos)))) + (insert (format "%s%s " file pos)))) (setq byte-compile-last-logged-file byte-compile-current-file byte-compile-last-warned-form byte-compile-current-form) entry) @@ -2007,7 +2008,7 @@ The value is non-nil if there were no errors, nil if errors." (delete-file tempfile))) kill-emacs-hook))) (unless (= temp-modes desired-modes) - (set-file-modes tempfile desired-modes)) + (set-file-modes tempfile desired-modes 'nofollow)) (write-region (point-min) (point-max) tempfile nil 1) ;; This has the intentional side effect that any ;; hard-links to target-file continue to @@ -2139,55 +2140,13 @@ With argument ARG, insert value in current buffer after the form." ;; Make warnings about unresolved functions ;; give the end of the file as their position. (setq byte-compile-last-position (point-max)) - (byte-compile-warn-about-unresolved-functions)) - ;; Fix up the header at the front of the output - ;; if the buffer contains multibyte characters. - (and byte-compile-current-file - (with-current-buffer byte-compile--outbuffer - (byte-compile-fix-header byte-compile-current-file)))) + (byte-compile-warn-about-unresolved-functions))) byte-compile--outbuffer))) -(defun byte-compile-fix-header (_filename) - "If the current buffer has any multibyte characters, insert a version test." - (when (< (point-max) (position-bytes (point-max))) - (goto-char (point-min)) - ;; Find the comment that describes the version condition. - (search-forward "\n;;; This file uses") - (narrow-to-region (line-beginning-position) (point-max)) - ;; Find the first line of ballast semicolons. - (search-forward ";;;;;;;;;;") - (beginning-of-line) - (narrow-to-region (point-min) (point)) - (let ((old-header-end (point)) - (minimum-version "23") - delta) - (delete-region (point-min) (point-max)) - (insert - ";;; This file contains utf-8 non-ASCII characters,\n" - ";;; and so cannot be loaded into Emacs 22 or earlier.\n" - ;; Have to check if emacs-version is bound so that this works - ;; in files loaded early in loadup.el. - "(and (boundp 'emacs-version)\n" - ;; If there is a name at the end of emacs-version, - ;; don't try to check the version number. - " (< (aref emacs-version (1- (length emacs-version))) ?A)\n" - (format " (string-lessp emacs-version \"%s\")\n" minimum-version) - ;; Because the header must fit in a fixed width, we cannot - ;; insert arbitrary-length file names (Bug#11585). - " (error \"`%s' was compiled for " - (format "Emacs %s or later\" #$))\n\n" minimum-version)) - ;; Now compensate for any change in size, to make sure all - ;; positions in the file remain valid. - (setq delta (- (point-max) old-header-end)) - (goto-char (point-max)) - (widen) - (delete-char delta)))) - (defun byte-compile-insert-header (_filename outbuffer) "Insert a header at the start of OUTBUFFER. Call from the source buffer." - (let ((dynamic-docstrings byte-compile-dynamic-docstrings) - (dynamic byte-compile-dynamic) + (let ((dynamic byte-compile-dynamic) (optimize byte-optimize)) (with-current-buffer outbuffer (goto-char (point-min)) @@ -2201,7 +2160,19 @@ Call from the source buffer." ;; 0 string ;ELC GNU Emacs Lisp compiled file, ;; >4 byte x version %d (insert - ";ELC" 23 "\000\000\000\n" + ";ELC" + (let ((version + (if (zerop emacs-minor-version) + ;; Let's allow silently loading into Emacs-27 + ;; files compiled with Emacs-28.0.NN since the two can + ;; be almost identical (e.g. right after cutting the + ;; release branch) and people running the development + ;; branch can be presumed to know that it's risky anyway. + (1- emacs-major-version) emacs-major-version))) + ;; Make sure the version is a plain byte that doesn't end the comment! + (cl-assert (and (> version 13) (< version 128))) + version) + "\000\000\000\n" ";;; Compiled\n" ";;; in Emacs version " emacs-version "\n" ";;; with" @@ -2213,19 +2184,7 @@ Call from the source buffer." ".\n" (if dynamic ";;; Function definitions are lazy-loaded.\n" "") - "\n;;; This file uses " - (if dynamic-docstrings - "dynamic docstrings, first added in Emacs 19.29" - "opcodes that do not exist in Emacs 18") - ".\n\n" - ;; Note that byte-compile-fix-header may change this. - ";;; This file does not contain utf-8 non-ASCII characters,\n" - ";;; and so can be loaded in Emacs versions earlier than 23.\n\n" - ;; Insert semicolons as ballast, so that byte-compile-fix-header - ;; can delete them so as to keep the buffer positions - ;; constant for the actual compiled code. - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n" - ";;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;\n\n")))) + "\n\n")))) (defun byte-compile-output-file-form (form) ;; Write the given form to the output buffer, being careful of docstrings @@ -3463,7 +3422,7 @@ for symbols generated by the byte compiler itself." (if (equal-including-properties (car elt) ,const) (setq result elt))) result) - (assq ,const byte-compile-constants)) + (assoc ,const byte-compile-constants #'eql)) (car (setq byte-compile-constants (cons (list ,const) byte-compile-constants))))) @@ -3491,7 +3450,7 @@ the opcode to be used. If function is a list, the first element is the function and the second element is the bytecode-symbol. The second element may be nil, meaning there is no opcode. COMPILE-HANDLER is the function to use to compile this byte-op, or -may be the abbreviations 0, 1, 2, 3, 0-1, or 1-2. +may be the abbreviations 0, 1, 2, 2-and, 3, 0-1, 1-2, 1-3, or 2-3. If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (let (opcode) (if (symbolp function) @@ -3510,6 +3469,7 @@ If it is nil, then the handler is \"byte-compile-SYMBOL.\"" (0-1 . byte-compile-zero-or-one-arg) (1-2 . byte-compile-one-or-two-args) (2-3 . byte-compile-two-or-three-args) + (1-3 . byte-compile-one-to-three-args) ))) compile-handler (intern (concat "byte-compile-" @@ -3694,6 +3654,13 @@ These implicitly `and' together a bunch of two-arg bytecodes." ((= len 4) (byte-compile-three-args form)) (t (byte-compile-subr-wrong-args form "2-3"))))) +(defun byte-compile-one-to-three-args (form) + (let ((len (length form))) + (cond ((= len 2) (byte-compile-three-args (append form '(nil nil)))) + ((= len 3) (byte-compile-three-args (append form '(nil)))) + ((= len 4) (byte-compile-three-args form)) + (t (byte-compile-subr-wrong-args form "1-3"))))) + (defun byte-compile-noop (_form) (byte-compile-constant nil)) @@ -4530,96 +4497,25 @@ binding slots have been popped." ;; (byte-defop-compiler-1 save-window-excursion) ;Obsolete: now a macro. ;; (byte-defop-compiler-1 with-output-to-temp-buffer) ;Obsolete: now a macro. -(defvar byte-compile--use-old-handlers nil - "If nil, use new byte codes introduced in Emacs-24.4.") - (defun byte-compile-catch (form) (byte-compile-form (car (cdr form))) - (if (not byte-compile--use-old-handlers) - (let ((endtag (byte-compile-make-tag))) - (byte-compile-goto 'byte-pushcatch endtag) - (byte-compile-body (cddr form) nil) - (byte-compile-out 'byte-pophandler) - (byte-compile-out-tag endtag)) - (pcase (cddr form) - (`(:fun-body ,f) - (byte-compile-form `(list 'funcall ,f))) - (body - (byte-compile-push-constant - (byte-compile-top-level (cons 'progn body) byte-compile--for-effect)))) - (byte-compile-out 'byte-catch 0))) + (let ((endtag (byte-compile-make-tag))) + (byte-compile-goto 'byte-pushcatch endtag) + (byte-compile-body (cddr form) nil) + (byte-compile-out 'byte-pophandler) + (byte-compile-out-tag endtag))) (defun byte-compile-unwind-protect (form) (pcase (cddr form) (`(:fun-body ,f) - (byte-compile-form - (if byte-compile--use-old-handlers `(list (list 'funcall ,f)) f))) + (byte-compile-form f)) (handlers - (if byte-compile--use-old-handlers - (byte-compile-push-constant - (byte-compile-top-level-body handlers t)) - (byte-compile-form `#'(lambda () ,@handlers))))) + (byte-compile-form `#'(lambda () ,@handlers)))) (byte-compile-out 'byte-unwind-protect 0) (byte-compile-form-do-effect (car (cdr form))) (byte-compile-out 'byte-unbind 1)) (defun byte-compile-condition-case (form) - (if byte-compile--use-old-handlers - (byte-compile-condition-case--old form) - (byte-compile-condition-case--new form))) - -(defun byte-compile-condition-case--old (form) - (let* ((var (nth 1 form)) - (fun-bodies (eq var :fun-body)) - (byte-compile-bound-variables - (if (and var (not fun-bodies)) - (cons var byte-compile-bound-variables) - byte-compile-bound-variables))) - (byte-compile-set-symbol-position 'condition-case) - (unless (symbolp var) - (byte-compile-warn - "`%s' is not a variable-name or nil (in condition-case)" var)) - (if fun-bodies (setq var (make-symbol "err"))) - (byte-compile-push-constant var) - (if fun-bodies - (byte-compile-form `(list 'funcall ,(nth 2 form))) - (byte-compile-push-constant - (byte-compile-top-level (nth 2 form) byte-compile--for-effect))) - (let ((compiled-clauses - (mapcar - (lambda (clause) - (let ((condition (car clause))) - (cond ((not (or (symbolp condition) - (and (listp condition) - (let ((ok t)) - (dolist (sym condition) - (if (not (symbolp sym)) - (setq ok nil))) - ok)))) - (byte-compile-warn - "`%S' is not a condition name or list of such (in condition-case)" - condition)) - ;; (not (or (eq condition 't) - ;; (and (stringp (get condition 'error-message)) - ;; (consp (get condition - ;; 'error-conditions))))) - ;; (byte-compile-warn - ;; "`%s' is not a known condition name - ;; (in condition-case)" - ;; condition)) - ) - (if fun-bodies - `(list ',condition (list 'funcall ,(cadr clause) ',var)) - (cons condition - (byte-compile-top-level-body - (cdr clause) byte-compile--for-effect))))) - (cdr (cdr (cdr form)))))) - (if fun-bodies - (byte-compile-form `(list ,@compiled-clauses)) - (byte-compile-push-constant compiled-clauses))) - (byte-compile-out 'byte-condition-case 0))) - -(defun byte-compile-condition-case--new (form) (let* ((var (nth 1 form)) (body (nth 2 form)) (depth byte-compile-depth) @@ -4857,6 +4753,14 @@ binding slots have been popped." (defun byte-compile-form-make-variable-buffer-local (form) (byte-compile-keep-pending form 'byte-compile-normal-call)) +;; Make `make-local-variable' declare the variable locally +;; dynamic - this suppresses some unnecessary warnings +(byte-defop-compiler-1 make-local-variable + byte-compile-make-local-variable) +(defun byte-compile-make-local-variable (form) + (pcase form (`(,_ ',var) (byte-compile--declare-var var))) + (byte-compile-normal-call form)) + (put 'function-put 'byte-hunk-handler 'byte-compile-define-symbol-prop) (put 'define-symbol-prop 'byte-hunk-handler 'byte-compile-define-symbol-prop) (defun byte-compile-define-symbol-prop (form) diff --git a/lisp/emacs-lisp/cconv.el b/lisp/emacs-lisp/cconv.el index e2e59337d7b..351a097ad19 100644 --- a/lisp/emacs-lisp/cconv.el +++ b/lisp/emacs-lisp/cconv.el @@ -462,20 +462,7 @@ places where they originally did not directly appear." ;; and may be an invalid expression (e.g. ($# . 678)). (cdr forms))))) - ;condition-case - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - (let ((newform (cconv--convert-function - () (list protected-form) env form))) - `(condition-case :fun-body ,newform - ,@(mapcar (lambda (handler) - (list (car handler) - (cconv--convert-function - (list (or var cconv--dummy-var)) - (cdr handler) env form))) - handlers)))) - - ; condition-case with new byte-codes. + ; condition-case (`(condition-case ,var ,protected-form . ,handlers) `(condition-case ,var ,(cconv-convert protected-form env extend) @@ -496,10 +483,8 @@ places where they originally did not directly appear." `((let ((,var (list ,var))) ,@body)))))) handlers)))) - (`(,(and head (or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect)) - ,form . ,body) - `(,head ,(cconv-convert form env extend) + (`(unwind-protect ,form . ,body) + `(unwind-protect ,(cconv-convert form env extend) :fun-body ,(cconv--convert-function () body env form))) (`(setq . ,forms) ; setq special form @@ -718,15 +703,6 @@ and updates the data stored in ENV." (`(quote . ,_) nil) ; quote form (`(function . ,_) nil) ; same as quote - ((and `(condition-case ,var ,protected-form . ,handlers) - (guard byte-compile--use-old-handlers)) - ;; FIXME: The bytecode for condition-case forces us to wrap the - ;; form and handlers in closures. - (cconv--analyze-function () (list protected-form) env form) - (dolist (handler handlers) - (cconv--analyze-function (if var (list var)) (cdr handler) - env form))) - (`(condition-case ,var ,protected-form . ,handlers) (cconv-analyze-form protected-form env) (when (and var (symbolp var) (byte-compile-not-lexical-var-p var)) @@ -741,9 +717,7 @@ and updates the data stored in ENV." form "variable")))) ;; FIXME: The bytecode for unwind-protect forces us to wrap the unwind. - (`(,(or (and 'catch (guard byte-compile--use-old-handlers)) - 'unwind-protect) - ,form . ,body) + (`(unwind-protect ,form . ,body) (cconv-analyze-form form env) (cconv--analyze-function () body env form)) diff --git a/lisp/emacs-lisp/check-declare.el b/lisp/emacs-lisp/check-declare.el index 144385ea27c..52cda95f4c1 100644 --- a/lisp/emacs-lisp/check-declare.el +++ b/lisp/emacs-lisp/check-declare.el @@ -1,4 +1,4 @@ -;;; check-declare.el --- Check declare-function statements +;;; check-declare.el --- Check declare-function statements -*- lexical-binding: t; -*- ;; Copyright (C) 2007-2020 Free Software Foundation, Inc. @@ -248,7 +248,7 @@ TYPE is a string giving the nature of the error. Optional LINE is the claim's line number; otherwise, search for the claim. Display warning in `check-declare-warning-buffer'." (let ((warning-prefix-function - (lambda (level entry) + (lambda (_level entry) (insert (format "%s:%d:" (file-relative-name file) (or line 0))) entry)) (warning-fill-prefix " ")) diff --git a/lisp/emacs-lisp/checkdoc.el b/lisp/emacs-lisp/checkdoc.el index 797493743c0..e4b800786cc 100644 --- a/lisp/emacs-lisp/checkdoc.el +++ b/lisp/emacs-lisp/checkdoc.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1997-1998, 2001-2020 Free Software Foundation, Inc. ;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Version: 0.6.2 +;; Old-Version: 0.6.2 ;; Keywords: docs, maint, lisp ;; This file is part of GNU Emacs. @@ -170,6 +170,7 @@ ;;; Code: (defvar checkdoc-version "0.6.2" "Release version of checkdoc you are currently running.") +(make-obsolete-variable 'checkdoc-version nil "28.1") (require 'cl-lib) (require 'help-mode) ;; for help-xref-info-regexp @@ -2642,7 +2643,7 @@ function called to create the messages." (goto-char (point-max)) (let ((inhibit-read-only t)) (insert "\n\n\C-l\n*** " label ": " - check-type " V " checkdoc-version))))) + check-type))))) (defun checkdoc-error (point msg) "Store POINT and MSG as errors in the checkdoc diagnostic buffer." diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index ce6fb625bc0..5bf74792c08 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -72,8 +72,7 @@ strings case-insensitively." (cond ((eq x y) t) ((stringp x) (and (stringp y) (= (length x) (length y)) - (or (string-equal x y) - (string-equal (downcase x) (downcase y))))) ;Lazy but simple! + (eq (compare-strings x nil nil y nil nil t) t))) ((numberp x) (and (numberp y) (= x y))) ((consp x) @@ -553,10 +552,9 @@ too large if positive or too small if negative)." (seq-subseq seq start end)) ;;;###autoload -(defun cl-concatenate (type &rest sequences) +(defalias 'cl-concatenate #'seq-concatenate "Concatenate, into a sequence of type TYPE, the argument SEQUENCEs. -\n(fn TYPE SEQUENCE...)" - (apply #'seq-concatenate type sequences)) +\n(fn TYPE SEQUENCE...)") ;;; List functions. diff --git a/lisp/emacs-lisp/cl-indent.el b/lisp/emacs-lisp/cl-indent.el index fd8715962a3..66502da668a 100644 --- a/lisp/emacs-lisp/cl-indent.el +++ b/lisp/emacs-lisp/cl-indent.el @@ -46,14 +46,12 @@ "Maximum depth to backtrack out from a sublist for structured indentation. If this variable is 0, no backtracking will occur and forms such as `flet' may not be correctly indented." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-indentation 1 "Indentation of tags relative to containing list. This variable is used by the function `lisp-indent-tagbody'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-tag-body-indentation 3 "Indentation of non-tagged lines relative to containing list. @@ -64,32 +62,30 @@ the special form. If the value is t, the body of tags will be indented as a block at the same indentation as the first s-expression following the tag. In this case, any forms before the first tag are indented by `lisp-body-indent'." - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-backquote-indentation t "Whether or not to indent backquoted lists as code. If nil, indent backquoted lists as data, i.e., like quoted lists." - :type 'boolean - :group 'lisp-indent) + :type 'boolean) -(defcustom lisp-loop-keyword-indentation 3 +(defcustom lisp-loop-keyword-indentation 6 "Indentation of loop keywords in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-loop-forms-indentation 5 +(defcustom lisp-loop-forms-indentation 6 "Indentation of forms in extended loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") -(defcustom lisp-simple-loop-indentation 3 +(defcustom lisp-simple-loop-indentation 1 "Indentation of forms in simple loop forms." :type 'integer - :group 'lisp-indent) + :version "28.1") (defcustom lisp-lambda-list-keyword-alignment nil "Whether to vertically align lambda-list keywords together. @@ -107,16 +103,14 @@ If non-nil, alignment is done with the first keyword &key key1 key2) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-lambda-list-keyword-parameter-indentation 2 "Indentation of lambda list keyword parameters. See `lisp-lambda-list-keyword-parameter-alignment' for more information." :version "24.1" - :type 'integer - :group 'lisp-indent) + :type 'integer) (defcustom lisp-lambda-list-keyword-parameter-alignment nil "Whether to vertically align lambda-list keyword parameters together. @@ -135,8 +129,7 @@ If non-nil, alignment is done with the first parameter key3 key4) #|...|#)" :version "24.1" - :type 'boolean - :group 'lisp-indent) + :type 'boolean) (defcustom lisp-indent-backquote-substitution-mode t "How to indent substitutions in backquotes. @@ -148,8 +141,7 @@ In any case, do not backtrack beyond a backquote substitution. Until Emacs 25.1, the nil behavior was hard-wired." :version "25.1" - :type '(choice (const corrected) (const nil) (const t)) - :group 'lisp-indent) + :type '(choice (const corrected) (const nil) (const t))) (defvar lisp-indent-defun-method '(4 &lambda &body) diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 78d083fcc63..6c1426ce5cb 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -75,7 +75,7 @@ ;; one, you may want to amend the other, too. ;;;###autoload (define-obsolete-function-alias 'cl--compiler-macro-cXXr - 'internal--compiler-macro-cXXr "25.1") + #'internal--compiler-macro-cXXr "25.1") ;;; Some predicates for analyzing Lisp forms. ;; These are used by various @@ -199,7 +199,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" [cl-&key-arg &rest cl-&key-arg] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-&optional-arg @@ -219,7 +219,7 @@ The name is made by appending a number to PREFIX, default \"T\"." [&optional ["&key" cl-&key-arg &rest cl-&key-arg &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-lambda-arg &optional def-form) arg]] . [&or arg nil]))) (def-edebug-spec cl-type-spec sexp) @@ -328,8 +328,7 @@ FORM is of the form (ARGS . BODY)." (setq cl--bind-lets (nreverse cl--bind-lets)) ;; (cl-assert (eq :dummy (nth 1 (car cl--bind-lets)))) (list '&rest (car (pop cl--bind-lets)))))))) - `(nil - (,@(nreverse simple-args) ,@rest-args) + `((,@(nreverse simple-args) ,@rest-args) ,@header ,(macroexp-let* cl--bind-lets (macroexp-progn @@ -366,9 +365,7 @@ more details. def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defun ,name ,@(cl--transform-lambda (cons args body) name))) ;;;###autoload (defmacro cl-iter-defun (name args &rest body) @@ -387,9 +384,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). (doc-string 3) (indent 2)) (require 'generator) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(iter-defun ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(iter-defun ,name ,@(cl--transform-lambda (cons args body) name))) ;; The lambda list for macros is different from that of normal lambdas. ;; Note that &environment is only allowed as first or last items in the @@ -407,7 +402,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] [&optional "&environment" arg] ))) @@ -426,7 +421,7 @@ and BODY is implicitly surrounded by (cl-block NAME ...). arg]] &optional "&allow-other-keys"]] [&optional ["&aux" &rest - &or (symbolp &optional def-form) symbolp]] + &or (cl-macro-arg &optional def-form) arg]] . [&or arg nil]))) ;;;###autoload @@ -455,9 +450,7 @@ more details. (&define name cl-macro-list cl-declarations-or-string def-body)) (doc-string 3) (indent 2)) - (let* ((res (cl--transform-lambda (cons args body) name)) - (form `(defmacro ,name ,@(cdr res)))) - (if (car res) `(progn ,(car res) ,form) form))) + `(defmacro ,name ,@(cl--transform-lambda (cons args body) name))) (def-edebug-spec cl-lambda-expr (&define ("lambda" cl-lambda-list @@ -480,9 +473,7 @@ Like normal `function', except that if argument is a lambda form, its argument list allows full Common Lisp conventions." (declare (debug (&or symbolp cl-lambda-expr))) (if (eq (car-safe func) 'lambda) - (let* ((res (cl--transform-lambda (cdr func) 'cl-none)) - (form `(function (lambda . ,(cdr res))))) - (if (car res) `(progn ,(car res) ,form) form)) + `(function (lambda . ,(cl--transform-lambda (cdr func) 'cl-none))) `(function ,func))) (defun cl--make-usage-var (x) @@ -723,9 +714,9 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (let ((comp (or (memq 'compile when) (memq :compile-toplevel when))) (cl--not-toplevel t)) (if (or (memq 'load when) (memq :load-toplevel when)) - (if comp (cons 'progn (mapcar 'cl--compile-time-too body)) + (if comp (cons 'progn (mapcar #'cl--compile-time-too body)) `(if nil nil ,@body)) - (progn (if comp (eval (cons 'progn body))) nil))) + (progn (if comp (eval (cons 'progn body) lexical-binding)) nil))) (and (or (memq 'eval when) (memq :execute when)) (cons 'progn body)))) @@ -734,13 +725,13 @@ If `eval' is in WHEN, BODY is evaluated when interpreted or at non-top-level. (setq form (macroexpand form (cons '(cl-eval-when) byte-compile-macro-environment)))) (cond ((eq (car-safe form) 'progn) - (cons 'progn (mapcar 'cl--compile-time-too (cdr form)))) + (cons 'progn (mapcar #'cl--compile-time-too (cdr form)))) ((eq (car-safe form) 'cl-eval-when) (let ((when (nth 1 form))) (if (or (memq 'eval when) (memq :execute when)) `(cl-eval-when (compile ,@when) ,@(cddr form)) form))) - (t (eval form) form))) + (t (eval form lexical-binding) form))) ;;;###autoload (defmacro cl-load-time-value (form &optional _read-only) @@ -766,7 +757,7 @@ The result of the body appears to the compiler as a quoted constant." ;; temp is set before we use it. (print set byte-compile--outbuffer)) temp) - `',(eval form))) + `',(eval form lexical-binding))) ;;; Conditional control structures. @@ -889,7 +880,7 @@ This is compatible with Common Lisp, but note that `defun' and ;;; The "cl-loop" macro. (defvar cl--loop-args) (defvar cl--loop-accum-var) (defvar cl--loop-accum-vars) -(defvar cl--loop-bindings) (defvar cl--loop-body) +(defvar cl--loop-bindings) (defvar cl--loop-body) (defvar cl--loop-conditions) (defvar cl--loop-finally) (defvar cl--loop-finish-flag) ;Symbol set to nil to exit the loop? (defvar cl--loop-first-flag) @@ -966,7 +957,8 @@ For more details, see Info node `(cl)Loop Facility'. (cl--loop-accum-var nil) (cl--loop-accum-vars nil) (cl--loop-initially nil) (cl--loop-finally nil) (cl--loop-iterator-function nil) (cl--loop-first-flag nil) - (cl--loop-symbol-macs nil)) + (cl--loop-symbol-macs nil) + (cl--loop-conditions nil)) ;; Here is more or less how those dynbind vars are used after looping ;; over cl--parse-loop-clause: ;; @@ -1034,6 +1026,13 @@ For more details, see Info node `(cl)Loop Facility'. (list `(cl-symbol-macrolet ,cl--loop-symbol-macs ,@body)))) `(cl-block ,cl--loop-name ,@body))))) +(defmacro cl--push-clause-loop-body (clause) + "Apply CLAUSE to both `cl--loop-conditions' and `cl--loop-body'." + (macroexp-let2 nil sym clause + `(progn + (push ,sym cl--loop-conditions) + (push ,sym cl--loop-body)))) + ;; Below is a complete spec for cl-loop, in several parts that correspond ;; to the syntax given in CLtL2. The specs do more than specify where ;; the forms are; it also specifies, as much as Edebug allows, all the @@ -1184,8 +1183,6 @@ For more details, see Info node `(cl)Loop Facility'. ;; (def-edebug-spec loop-d-type-spec ;; (&or (loop-d-type-spec . [&or nil loop-d-type-spec]) cl-type-spec)) - - (defun cl--parse-loop-clause () ; uses loop-* (let ((word (pop cl--loop-args)) (hash-types '(hash-key hash-keys hash-value hash-values)) @@ -1264,11 +1261,11 @@ For more details, see Info node `(cl)Loop Facility'. (if end-var (push (list end-var end) loop-for-bindings)) (if step-var (push (list step-var step) loop-for-bindings)) - (if end - (push (list - (if down (if excl '> '>=) (if excl '< '<=)) - var (or end-var end)) - cl--loop-body)) + (when end + (cl--push-clause-loop-body + (list + (if down (if excl '> '>=) (if excl '< '<=)) + var (or end-var end)))) (push (list var (list (if down '- '+) var (or step-var step 1))) loop-for-steps))) @@ -1278,7 +1275,7 @@ For more details, see Info node `(cl)Loop Facility'. (temp (if (and on (symbolp var)) var (make-symbol "--cl-var--")))) (push (list temp (pop cl--loop-args)) loop-for-bindings) - (push `(consp ,temp) cl--loop-body) + (cl--push-clause-loop-body `(consp ,temp)) (if (eq word 'in-ref) (push (list var `(car ,temp)) cl--loop-symbol-macs) (or (eq temp var) @@ -1301,33 +1298,31 @@ For more details, see Info node `(cl)Loop Facility'. ((eq word '=) (let* ((start (pop cl--loop-args)) (then (if (eq (car cl--loop-args) 'then) - (cl--pop2 cl--loop-args) start))) + (cl--pop2 cl--loop-args) start)) + (first-assign (or cl--loop-first-flag + (setq cl--loop-first-flag + (make-symbol "--cl-var--"))))) (push (list var nil) loop-for-bindings) (if (or ands (eq (car cl--loop-args) 'and)) (progn - (push `(,var - (if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,var)) - loop-for-sets) - (push (list var then) loop-for-steps)) - (push (list var - (if (eq start then) start - `(if ,(or cl--loop-first-flag - (setq cl--loop-first-flag - (make-symbol "--cl-var--"))) - ,start ,then))) - loop-for-sets)))) + (push `(,var (if ,first-assign ,start ,var)) loop-for-sets) + (push `(,var (if ,(car (cl--loop-build-ands + (nreverse cl--loop-conditions))) + ,then ,var)) + loop-for-steps)) + (push (if (eq start then) + `(,var ,then) + `(,var (if ,first-assign ,start ,then))) + loop-for-sets)))) ((memq word '(across across-ref)) (let ((temp-vec (make-symbol "--cl-vec--")) (temp-idx (make-symbol "--cl-idx--"))) (push (list temp-vec (pop cl--loop-args)) loop-for-bindings) (push (list temp-idx -1) loop-for-bindings) - (push `(< (setq ,temp-idx (1+ ,temp-idx)) - (length ,temp-vec)) - cl--loop-body) + (push `(setq ,temp-idx (1+ ,temp-idx)) cl--loop-body) + (cl--push-clause-loop-body + `(< ,temp-idx (length ,temp-vec))) (if (eq word 'across-ref) (push (list var `(aref ,temp-vec ,temp-idx)) cl--loop-symbol-macs) @@ -1351,17 +1346,16 @@ For more details, see Info node `(cl)Loop Facility'. (push (list temp-seq seq) loop-for-bindings) (push (list temp-idx 0) loop-for-bindings) (if ref - (let ((temp-len (make-symbol "--cl-len--"))) + (let ((temp-len (make-symbol "--cl-len--"))) (push (list temp-len `(length ,temp-seq)) loop-for-bindings) (push (list var `(elt ,temp-seq ,temp-idx)) cl--loop-symbol-macs) - (push `(< ,temp-idx ,temp-len) cl--loop-body)) + (cl--push-clause-loop-body `(< ,temp-idx ,temp-len))) (push (list var nil) loop-for-bindings) - (push `(and ,temp-seq - (or (consp ,temp-seq) - (< ,temp-idx (length ,temp-seq)))) - cl--loop-body) + (cl--push-clause-loop-body `(and ,temp-seq + (or (consp ,temp-seq) + (< ,temp-idx (length ,temp-seq))))) (push (list var `(if (consp ,temp-seq) (pop ,temp-seq) (aref ,temp-seq ,temp-idx))) @@ -1457,9 +1451,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list var '(selected-frame)) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-frame ,var)) loop-for-steps))) @@ -1480,9 +1473,8 @@ For more details, see Info node `(cl)Loop Facility'. (push (list minip `(minibufferp (window-buffer ,var))) loop-for-bindings) (push (list temp nil) loop-for-bindings) - (push `(prog1 (not (eq ,var ,temp)) - (or ,temp (setq ,temp ,var))) - cl--loop-body) + (cl--push-clause-loop-body `(prog1 (not (eq ,var ,temp)) + (or ,temp (setq ,temp ,var)))) (push (list var `(next-window ,var ,minip)) loop-for-steps))) @@ -1498,17 +1490,17 @@ For more details, see Info node `(cl)Loop Facility'. (pop cl--loop-args)) (if (and ands loop-for-bindings) (push (nreverse loop-for-bindings) cl--loop-bindings) - (setq cl--loop-bindings (nconc (mapcar 'list loop-for-bindings) - cl--loop-bindings))) + (setq cl--loop-bindings (nconc (mapcar #'list loop-for-bindings) + cl--loop-bindings))) (if loop-for-sets (push `(progn ,(cl--loop-let (nreverse loop-for-sets) 'setq ands) t) cl--loop-body)) - (if loop-for-steps - (push (cons (if ands 'cl-psetq 'setq) - (apply 'append (nreverse loop-for-steps))) - cl--loop-steps)))) + (when loop-for-steps + (push (cons (if ands 'cl-psetq 'setq) + (apply #'append (nreverse loop-for-steps))) + cl--loop-steps)))) ((eq word 'repeat) (let ((temp (make-symbol "--cl-var--"))) @@ -1700,7 +1692,7 @@ If BODY is `setq', then use SPECS for assignments rather than for bindings." (push binding new)))) (if (eq body 'setq) (let ((set (cons (if par 'cl-psetq 'setq) - (apply 'nconc (nreverse new))))) + (apply #'nconc (nreverse new))))) (if temps `(let* ,(nreverse temps) ,set) set)) `(,(if par 'let 'let*) ,(nconc (nreverse temps) (nreverse new)) ,@body)))) @@ -1826,7 +1818,7 @@ For more details, see `cl-do*' description in Info node `(cl) Iteration'. (and sets (list (cons (if (or star (not (cdr sets))) 'setq 'cl-psetq) - (apply 'append sets)))))) + (apply #'append sets)))))) ,@(or (cdr endtest) '(nil))))) ;;;###autoload @@ -2105,10 +2097,9 @@ This is like `cl-flet', but for macros instead of functions. (if (null bindings) (macroexp-progn body) (let* ((name (caar bindings)) (res (cl--transform-lambda (cdar bindings) name))) - (eval (car res)) (macroexpand-all (macroexp-progn body) (cons (cons name - (eval `(cl-function (lambda ,@(cdr res))) t)) + (eval `(function (lambda ,@res)) t)) macroexpand-all-environment)))))) (defun cl--sm-macroexpand (orig-fun exp &optional env) @@ -2472,7 +2463,7 @@ Each PLACE may be a symbol, or any generalized variable allowed by `setf'. \(fn PLACE...)" (declare (debug (&rest place))) - (if (not (memq nil (mapcar 'symbolp args))) + (if (not (memq nil (mapcar #'symbolp args))) (and (cdr args) (let ((sets nil) (first (car args))) @@ -2872,7 +2863,9 @@ Supported keywords for slots are: (append pred-form '(t)) `(and ,pred-form t))) forms) - (push `(put ',name 'cl-deftype-satisfies ',predicate) forms)) + (push `(eval-and-compile + (put ',name 'cl-deftype-satisfies ',predicate)) + forms)) (let ((pos 0) (descp descs)) (while descp (let* ((desc (pop descp)) @@ -2972,14 +2965,26 @@ Supported keywords for slots are: (pcase-dolist (`(,cname ,args ,doc) constrs) (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) - slots defaults))) - (push `(,cldefsym ,cname + slots defaults)) + ;; `cl-defsubst' is fundamentally broken: it substitutes + ;; its arguments into the body's `sexp' much too naively + ;; when inlinling, which results in various problems. + ;; For example it generates broken code if your + ;; argument's name happens to be the same as some + ;; function used within the body. + ;; E.g. (cl-defsubst sm-foo (list) (list list)) + ;; will expand `(sm-foo 1)' to `(1 1)' rather than to `(list t)'! + ;; Try to catch this known case! + (con-fun (or type #'record)) + (unsafe-cl-defsubst + (or (memq con-fun args) (assq con-fun args)))) + (push `(,(if unsafe-cl-defsubst 'cl-defun cldefsym) ,cname (&cl-defs (nil ,@descs) ,@args) ,(if (stringp doc) doc (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) - (,(or type #'record) ,@make)) + (,con-fun ,@make)) forms))) (if print-auto (nconc print-func (list '(princ ")" cl-s) t))) ;; Don't bother adding to cl-custom-print-functions since it's not used @@ -3132,13 +3137,34 @@ Of course, we really can't know that for sure, so it's just a heuristic." (or (cdr (assq sym byte-compile-function-environment)) (cdr (assq sym byte-compile-macro-environment)))))) -(put 'null 'cl-deftype-satisfies #'null) -(put 'atom 'cl-deftype-satisfies #'atom) -(put 'real 'cl-deftype-satisfies #'numberp) -(put 'fixnum 'cl-deftype-satisfies #'integerp) -(put 'base-char 'cl-deftype-satisfies #'characterp) -(put 'character 'cl-deftype-satisfies #'natnump) - +(pcase-dolist (`(,type . ,pred) + ;; Mostly kept in alphabetical order. + '((array . arrayp) + (atom . atom) + (base-char . characterp) + (boolean . booleanp) + (bool-vector . bool-vector-p) + (buffer . bufferp) + (character . natnump) + (char-table . char-table-p) + (cons . consp) + (fixnum . integerp) + (float . floatp) + (function . functionp) + (integer . integerp) + (keyword . keywordp) + (list . listp) + (number . numberp) + (null . null) + (real . numberp) + (sequence . sequencep) + (string . stringp) + (symbol . symbolp) + (vector . vectorp) + ;; FIXME: Do we really want to consider this a type? + (integer-or-marker . integer-or-marker-p) + )) + (put type 'cl-deftype-satisfies pred)) ;;;###autoload (define-inline cl-typep (val type) @@ -3207,7 +3233,10 @@ STRING is an optional description of the desired type." (macroexp-let2 macroexp-copyable-p temp form `(progn (or (cl-typep ,temp ',type) (signal 'wrong-type-argument - (list ,(or string `',type) ,temp ',form))) + (list ,(or string `',(if (eq 'satisfies + (car-safe type)) + (cadr type) type)) + ,temp ',form))) nil)))) ;;;###autoload diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a0bc6562bc9..78461185d3a 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -741,6 +741,21 @@ Maybe clear the markers and delete the symbol's edebug property?" ;;; Offsets for reader +(defun edebug-get-edebug-or-ghost (name) + "Get NAME's value of property `edebug' or property `ghost-edebug'. + +The idea is that should function NAME be recompiled whilst +debugging is in progress, property `edebug' will get set to a +marker. The needed data will then come from property +`ghost-edebug'." + (let ((e (get name 'edebug))) + (if (consp e) + e + (let ((g (get name 'ghost-edebug))) + (if (consp g) + g + e))))) + ;; Define a structure to represent offset positions of expressions. ;; Each offset structure looks like: (before . after) for constituents, ;; or for structures that have elements: (before <subexpressions> . after) @@ -1168,6 +1183,12 @@ purpose by adding an entry to this alist, and setting ;; Not edebugging this form, so reset the symbol's edebug ;; property to be just a marker at the definition's source code. ;; This only works for defs with simple names. + + ;; Preserve the `edebug' property in case there's + ;; debugging still under way. + (let ((ghost (get def-name 'edebug))) + (if (consp ghost) + (put def-name 'ghost-edebug ghost))) (put def-name 'edebug (point-marker)) ;; Also nil out dependent defs. '(mapcar (function @@ -1411,6 +1432,8 @@ contains a circular object." (cons window (window-start window))))) ;; Store the edebug data in symbol's property list. + ;; We actually want to remove this property entirely, but can't. + (put edebug-def-name 'ghost-edebug nil) (put edebug-def-name 'edebug ;; A struct or vector would be better here!! (list edebug-form-begin-marker @@ -1423,8 +1446,8 @@ contains a circular object." ))) (defun edebug--restore-breakpoints (name) - (let ((data (get name 'edebug))) - (when (listp data) + (let ((data (edebug-get-edebug-or-ghost name))) + (when (consp data) (let ((offsets (nth 2 data)) (breakpoints (nth 1 data)) (start (nth 0 data)) @@ -1714,6 +1737,7 @@ contains a circular object." (cl-macrolet-body . edebug-match-cl-macrolet-body) (¬ . edebug-match-¬) (&key . edebug-match-&key) + (&error . edebug-match-&error) (place . edebug-match-place) (gate . edebug-match-gate) ;; (nil . edebug-match-nil) not this one - special case it. @@ -1832,9 +1856,6 @@ contains a circular object." ;; This means nothing matched, so it is OK. nil) ;; So, return nothing - -(def-edebug-spec &key edebug-match-&key) - (defun edebug-match-&key (cursor specs) ;; Following specs must look like (<name> <spec>) ... ;; where <name> is the name of a keyword, and spec is its spec. @@ -1847,6 +1868,15 @@ contains a circular object." (car (cdr pair)))) specs)))) +(defun edebug-match-&error (cursor specs) + ;; Signal an error, using the following string in the spec as argument. + (let ((error-string (car specs)) + (edebug-error-point (edebug-before-offset cursor))) + (goto-char edebug-error-point) + (error "%s" + (if (stringp error-string) + error-string + "String expected after &error in edebug-spec")))) (defun edebug-match-gate (_cursor) ;; Simply set the gate to prevent backtracking at this level. @@ -2105,10 +2135,10 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec edebug-spec (&or + edebug-spec-list (vector &rest edebug-spec) ; matches a vector ("vector" &rest edebug-spec) ; matches a vector spec ("quote" symbolp) - edebug-spec-list stringp [edebug-lambda-list-keywordp &rest edebug-spec] [keywordp gate edebug-spec] @@ -2216,6 +2246,8 @@ into `edebug--cl-macrolet-defs' which is checked in `edebug-list-form-args'." (def-edebug-spec nested-backquote-form (&or + ("`" &error "Triply nested backquotes (without commas \"between\" them) \ +are too difficult to instrument") ;; Allow instrumentation of any , or ,@ contained within the (\, ...) or ;; (\,@ ...) matched on the next line. ([&or "," ",@"] backquote-form) @@ -2755,6 +2787,7 @@ See `edebug-behavior-alist' for implementations.") (edebug-stop)) (edebug-overlay-arrow) + (edebug--overlay-breakpoints edebug-function) (unwind-protect (if (or edebug-stop @@ -2832,7 +2865,6 @@ See `edebug-behavior-alist' for implementations.") (if (not (eq edebug-buffer edebug-outside-buffer)) (goto-char edebug-outside-point)) (if (marker-buffer (edebug-mark-marker)) - ;; Does zmacs-regions need to be nil while doing set-marker? (set-marker (edebug-mark-marker) edebug-outside-mark)) )) ; unwind-protect ;; None of the following is done if quit or signal occurs. @@ -2844,6 +2876,7 @@ See `edebug-behavior-alist' for implementations.") (goto-char edebug-buffer-outside-point)) ;; ... nothing more. ) + (edebug--overlay-breakpoints-remove (point-min) (point-max)) ;; Could be an option to keep eval display up. (if edebug-eval-buffer (kill-buffer edebug-eval-buffer)) (with-timeout-unsuspend edebug-with-timeout-suspend) @@ -3118,7 +3151,7 @@ before returning. The default is one second." ;; Return (function . index) of the nearest edebug stop point. (let* ((edebug-def-name (edebug-form-data-symbol)) (edebug-data - (let ((data (get edebug-def-name 'edebug))) + (let ((data (edebug-get-edebug-or-ghost edebug-def-name))) (if (or (null data) (markerp data)) (error "%s is not instrumented for Edebug" edebug-def-name)) data)) ; we could do it automatically, if data is a marker. @@ -3155,7 +3188,7 @@ before returning. The default is one second." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3196,7 +3229,7 @@ the breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) ;; pull out parts of edebug-data (edebug-def-mark (car edebug-data)) @@ -3228,7 +3261,45 @@ the breakpoint." (setcar (cdr edebug-data) edebug-breakpoints) (goto-char position) - )))) + (edebug--overlay-breakpoints edebug-def-name))))) + +(define-fringe-bitmap 'edebug-breakpoint + "\x3c\x7e\xff\xff\xff\xff\x7e\x3c") + +(defun edebug--overlay-breakpoints (function) + (let* ((data (edebug-get-edebug-or-ghost function)) + (start (nth 0 data)) + (breakpoints (nth 1 data)) + (offsets (nth 2 data))) + ;; First remove all old breakpoint overlays. + (edebug--overlay-breakpoints-remove + start (+ start (aref offsets (1- (length offsets))))) + ;; Then make overlays for the breakpoints (but only when we are in + ;; edebug mode). + (when edebug-active + (dolist (breakpoint breakpoints) + (let* ((pos (+ start (aref offsets (car breakpoint)))) + (overlay (make-overlay pos (1+ pos))) + (face (if (nth 4 breakpoint) + (progn + (overlay-put overlay + 'help-echo "Disabled breakpoint") + (overlay-put overlay + 'face 'edebug-disabled-breakpoint)) + (overlay-put overlay 'help-echo "Breakpoint") + (overlay-put overlay 'face 'edebug-enabled-breakpoint)))) + (overlay-put overlay 'edebug t) + (let ((fringe (make-overlay pos pos))) + (overlay-put fringe 'edebug t) + (overlay-put fringe 'before-string + (propertize + "x" 'display + `(left-fringe edebug-breakpoint ,face))))))))) + +(defun edebug--overlay-breakpoints-remove (start end) + (dolist (overlay (overlays-in start end)) + (when (overlay-get overlay 'edebug) + (delete-overlay overlay)))) (defun edebug-set-breakpoint (arg) "Set the breakpoint of nearest sexp. @@ -3236,9 +3307,9 @@ With prefix argument, make it a temporary breakpoint." (interactive "P") ;; If the form hasn't been instrumented yet, do it now. (when (and (not edebug-active) - (let ((data (get (edebug--form-data-name - (edebug-get-form-data-entry (point))) - 'edebug))) + (let ((data (edebug-get-edebug-or-ghost + (edebug--form-data-name + (edebug-get-form-data-entry (point)))))) (or (null data) (markerp data)))) (edebug-defun)) (edebug-modify-breakpoint t nil arg)) @@ -3252,7 +3323,7 @@ With prefix argument, make it a temporary breakpoint." "Unset all the breakpoints in the current form." (interactive) (let* ((name (edebug-form-data-symbol)) - (breakpoints (nth 1 (get name 'edebug)))) + (breakpoints (nth 1 (edebug-get-edebug-or-ghost name)))) (unless breakpoints (user-error "There are no breakpoints in %s" name)) (save-excursion @@ -3268,12 +3339,13 @@ With prefix argument, make it a temporary breakpoint." (user-error "No stop point near point")) (let* ((name (car stop-point)) (index (cdr stop-point)) - (data (get name 'edebug)) + (data (edebug-get-edebug-or-ghost name)) (breakpoint (assq index (nth 1 data)))) (unless breakpoint (user-error "No breakpoint near point")) (setf (nth 4 breakpoint) - (not (nth 4 breakpoint)))))) + (not (nth 4 breakpoint))) + (edebug--overlay-breakpoints name)))) (defun edebug-set-global-break-condition (expression) "Set `edebug-global-break-condition' to EXPRESSION." @@ -3448,7 +3520,7 @@ instrument cannot be found, signal an error." (goto-char func-marker) (edebug-eval-top-level-form) (list func))) - ((consp func-marker) + ((and (consp func-marker) (consp (symbol-function func))) (message "%s is already instrumented." func) (list func)) (t @@ -3667,7 +3739,6 @@ Return the result of the last expression." (prin1-to-string edebug-arg)) (cdr value) ", "))) -(defvar print-readably) ; defined by lemacs ;; Alternatively, we could change the definition of ;; edebug-safe-prin1-to-string to only use these if defined. @@ -3675,8 +3746,7 @@ Return the result of the last expression." (let ((print-escape-newlines t) (print-length (or edebug-print-length print-length)) (print-level (or edebug-print-level print-level)) - (print-circle (or edebug-print-circle print-circle)) - (print-readably nil)) ; lemacs uses this. + (print-circle (or edebug-print-circle print-circle))) (edebug-prin1-to-string value))) (defun edebug-compute-previous-result (previous-value) @@ -4223,7 +4293,7 @@ Save DEF-NAME, BEFORE-INDEX and AFTER-INDEX in FRAME." (let* ((index (backtrace-get-index)) (frame (nth index backtrace-frames))) (when (edebug--frame-def-name frame) - (let* ((data (get (edebug--frame-def-name frame) 'edebug)) + (let* ((data (edebug-get-edebug-or-ghost (edebug--frame-def-name frame))) (marker (nth 0 data)) (offsets (nth 2 data))) (pop-to-buffer (marker-buffer marker)) @@ -4307,7 +4377,7 @@ reinstrument it." (let* ((function (edebug-form-data-symbol)) (counts (get function 'edebug-freq-count)) (coverages (get function 'edebug-coverage)) - (data (get function 'edebug)) + (data (edebug-get-edebug-or-ghost function)) (def-mark (car data)) ; mark at def start (edebug-points (nth 2 data)) (i (1- (length edebug-points))) @@ -4465,7 +4535,7 @@ With prefix argument, make it a temporary breakpoint." (if edebug-stop-point (let* ((edebug-def-name (car edebug-stop-point)) (index (cdr edebug-stop-point)) - (edebug-data (get edebug-def-name 'edebug)) + (edebug-data (edebug-get-edebug-or-ghost edebug-def-name)) (edebug-breakpoints (car (cdr edebug-data))) (edebug-break-data (assq index edebug-breakpoints)) (edebug-break-condition (car (cdr edebug-break-data))) @@ -4479,17 +4549,6 @@ With prefix argument, make it a temporary breakpoint." (edebug-modify-breakpoint t condition arg)) (easy-menu-define edebug-menu edebug-mode-map "Edebug menus" edebug-mode-menus) - -;;; Autoloading of Edebug accessories - -;; edebug-cl-read and cl-read are available from liberte@cs.uiuc.edu -(defun edebug--require-cl-read () - (require 'edebug-cl-read)) - -(if (featurep 'cl-read) - (add-hook 'edebug-setup-hook #'edebug--require-cl-read) - ;; The following causes edebug-cl-read to be loaded when you load cl-read.el. - (add-hook 'cl-read-load-hooks #'edebug--require-cl-read)) ;;; Finalize Loading @@ -4525,7 +4584,6 @@ With prefix argument, make it a temporary breakpoint." (run-with-idle-timer 0 nil #'(lambda () (unload-feature 'edebug))))) (remove-hook 'called-interactively-p-functions #'edebug--called-interactively-skip) - (remove-hook 'cl-read-load-hooks #'edebug--require-cl-read) (edebug-uninstall-read-eval-functions) ;; Continue standard unloading. nil) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 1e53f30a2ae..3bc65d0d4c5 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -730,7 +730,8 @@ Argument FN is the function calling this verifier." (guard (not (memq name eieio--known-slot-names)))) (macroexp--warn-and-return (format-message "Unknown slot `%S'" name) exp 'compile-only)) - (_ exp))))) + (_ exp)))) + (gv-setter eieio-oset)) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) @@ -755,6 +756,7 @@ Argument FN is the function calling this verifier." (defun eieio-oref-default (obj slot) "Do the work for the macro `oref-default' with similar parameters. Fills in OBJ's SLOT with its default value." + (declare (gv-setter eieio-oset-default)) (cl-check-type obj (or eieio-object class)) (cl-check-type slot symbol) (let* ((cl (cond ((symbolp obj) (cl--find-class obj)) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index dda90373069..59af7e12d21 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -278,14 +278,7 @@ are not abstract." (if eieio-class-speedbar-key-map nil - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook (lambda () - (eieio-class-speedbar-make-map) - (speedbar-add-expansion-list - '("EIEIO" - eieio-class-speedbar-menu - eieio-class-speedbar-key-map - eieio-class-speedbar)))) + (with-eval-after-load 'speedbar (eieio-class-speedbar-make-map) (speedbar-add-expansion-list '("EIEIO" eieio-class-speedbar-menu diff --git a/lisp/emacs-lisp/eieio-speedbar.el b/lisp/emacs-lisp/eieio-speedbar.el index c11608da5d8..5c6e0e516d1 100644 --- a/lisp/emacs-lisp/eieio-speedbar.el +++ b/lisp/emacs-lisp/eieio-speedbar.el @@ -140,11 +140,7 @@ MENU-VAR is the symbol containing an easymenu compatible menu part to use. MODENAME is a string used to identify this browser mode. FETCHER is a generic function used to fetch the base object list used when creating the speedbar display." - (if (not (featurep 'speedbar)) - (add-hook 'speedbar-load-hook - (list 'lambda nil - (list 'eieio-speedbar-create-engine - map-fn map-var menu-var modename fetcher))) + (with-eval-after-load 'speedbar (eieio-speedbar-create-engine map-fn map-var menu-var modename fetcher))) (defun eieio-speedbar-create-engine (map-fn map-var menu-var modename fetcher) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 9f8b639e52d..b75410ee220 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -351,24 +351,20 @@ Elements of FIELDS can be of the form (NAME PAT) in which case the contents of field NAME is matched against PAT, or they can be of the form NAME which is a shorthand for (NAME NAME)." (declare (debug (&rest [&or (sexp pcase-PAT) sexp]))) - (let ((is (make-symbol "table"))) - ;; FIXME: This generates a horrendous mess of redundant let bindings. - ;; `pcase' needs to be improved somehow to introduce let-bindings more - ;; sparingly, or the byte-compiler needs to be taught to optimize - ;; them away. - ;; FIXME: `pcase' does not do a good job here of sharing tests&code among - ;; various branches. - `(and (pred eieio-object-p) - (app eieio-pcase-slot-index-table ,is) - ,@(mapcar (lambda (field) - (let* ((name (if (consp field) (car field) field)) - (pat (if (consp field) (cadr field) field)) - (i (make-symbol "index"))) - `(and (let (and ,i (pred natnump)) - (eieio-pcase-slot-index-from-index-table - ,is ',name)) - (app (pcase--flip aref ,i) ,pat)))) - fields)))) + ;; FIXME: This generates a horrendous mess of redundant let bindings. + ;; `pcase' needs to be improved somehow to introduce let-bindings more + ;; sparingly, or the byte-compiler needs to be taught to optimize + ;; them away. + ;; FIXME: `pcase' does not do a good job here of sharing tests&code among + ;; various branches. + `(and (pred eieio-object-p) + ,@(mapcar (lambda (field) + (pcase-exhaustive field + (`(,name ,pat) + `(app (pcase--flip eieio-oref ',name) ,pat)) + ((pred symbolp) + `(app (pcase--flip eieio-oref ',field) ,field)))) + fields))) ;;; Simple generators, and query functions. None of these would do ;; well embedded into an object. @@ -649,14 +645,6 @@ If SLOT is unbound, do nothing." nil (eieio-oset object slot (delete item (eieio-oref object slot))))) -;;; Here are some CLOS items that need the CL package -;; - -;; FIXME: Shouldn't this be a more complex gv-expander which extracts the -;; common code between oref and oset, so as to reduce the redundant work done -;; in (push foo (oref bar baz)), like we do for the `nth' expander? -(gv-define-simple-setter eieio-oref eieio-oset) - ;;; ;; We want all objects created by EIEIO to have some default set of diff --git a/lisp/emacs-lisp/eldoc.el b/lisp/emacs-lisp/eldoc.el index 7a7b8ec1647..19b3bd78aea 100644 --- a/lisp/emacs-lisp/eldoc.el +++ b/lisp/emacs-lisp/eldoc.el @@ -5,6 +5,11 @@ ;; Author: Noah Friedman <friedman@splode.com> ;; Keywords: extensions ;; Created: 1995-10-06 +;; Version: 1.8.0 +;; Package-Requires: ((emacs "26.3")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -32,20 +37,18 @@ ;; the one-line documentation for that variable instead, to remind you of ;; that variable's meaning. -;; One useful way to enable this minor mode is to put the following in your -;; .emacs: -;; -;; (add-hook 'emacs-lisp-mode-hook 'eldoc-mode) -;; (add-hook 'lisp-interaction-mode-hook 'eldoc-mode) -;; (add-hook 'ielm-mode-hook 'eldoc-mode) -;; (add-hook 'eval-expression-minibuffer-setup-hook 'eldoc-mode) +;; This mode is now enabled by default in all major modes that provide +;; support for it, such as `emacs-lisp-mode'. +;; This is controlled by `global-eldoc-mode'. -;; Major modes for other languages may use ElDoc by defining an -;; appropriate function as the buffer-local value of -;; `eldoc-documentation-function'. +;; Major modes for other languages may use ElDoc by adding an +;; appropriate function to the buffer-local value of +;; `eldoc-documentation-functions'. ;;; Code: +(eval-when-compile (require 'cl-lib)) + (defgroup eldoc nil "Show function arglist or variable docstring in echo area." :group 'lisp @@ -57,20 +60,17 @@ If user input arrives before this interval of time has elapsed after the last input, no documentation will be printed. If this variable is set to 0, no idle time is required." - :type 'number - :group 'eldoc) + :type 'number) (defcustom eldoc-print-after-edit nil "If non-nil eldoc info is only shown when editing. Changing the value requires toggling `eldoc-mode'." - :type 'boolean - :group 'eldoc) + :type 'boolean) ;;;###autoload (defcustom eldoc-minor-mode-string (purecopy " ElDoc") "String to display in mode line when ElDoc Mode is enabled; nil for none." - :type '(choice string (const :tag "None" nil)) - :group 'eldoc) + :type '(choice string (const :tag "None" nil))) (defcustom eldoc-argument-case #'identity "Case to display argument names of functions, as a symbol. @@ -79,42 +79,51 @@ Actually, any name of a function which takes a string as an argument and returns another string is acceptable. Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." +`eldoc-documentation-strategy' handles it explicitly." :type '(radio (function-item upcase) (function-item downcase) - function) - :group 'eldoc) + function)) (make-obsolete-variable 'eldoc-argument-case nil "25.1") (defcustom eldoc-echo-area-use-multiline-p 'truncate-sym-name-if-fit - "Allow long ElDoc messages to resize echo area display. -If value is t, never attempt to truncate messages; complete symbol name -and function arglist or 1-line variable documentation will be displayed -even if echo area must be resized to fit. - -If value is any non-nil value other than t, symbol name may be truncated -if it will enable the function arglist or documentation string to fit on a -single line without resizing window. Otherwise, behavior is just like -former case. - -If value is nil, messages are always truncated to fit in a single line of -display in the echo area. Function or variable symbol name may be -truncated to make more of the arglist or documentation string visible. - -Note that this variable has no effect, unless -`eldoc-documentation-function' handles it explicitly." - :type '(radio (const :tag "Always" t) - (const :tag "Never" nil) - (const :tag "Yes, but truncate symbol names if it will\ - enable argument list to fit on one line" truncate-sym-name-if-fit)) - :group 'eldoc) + "Allow long ElDoc doc strings to resize echo area display. +If value is t, never attempt to truncate messages, even if the +echo area must be resized to fit. + +If value is a number (integer or floating point), it has the +semantics of `max-mini-window-height', constraining the resizing +for ElDoc purposes only. + +Any resizing respects `max-mini-window-height'. + +If value is any non-nil symbol other than t, the part of the doc +string that represents the symbol's name may be truncated if it +will enable the rest of the doc string to fit on a single line, +without resizing the echo area. + +If value is nil, a doc string is always truncated to fit in a +single line of display in the echo area." + :type '(radio (const :tag "Always" t) + (float :tag "Fraction of frame height" 0.25) + (integer :tag "Number of lines" 5) + (const :tag "Never" nil) + (const :tag "Yes, but ask major-mode to truncate + symbol names if it will\ enable argument list to fit on one + line" truncate-sym-name-if-fit))) + +(defcustom eldoc-prefer-doc-buffer nil + "Prefer ElDoc's documentation buffer if it is showing in some frame. +If this variable's value is t and a piece of documentation needs +to be truncated to fit in the echo area, do so if ElDoc's +documentation buffer is not already showing, since the buffer +always holds the full documentation." + :type 'boolean) (defface eldoc-highlight-function-argument '((t (:inherit bold))) "Face used for the argument at point in a function's argument list. -Note that this face has no effect unless the `eldoc-documentation-function' -handles it explicitly." - :group 'eldoc) +Note that this face has no effect unless the `eldoc-documentation-strategy' +handles it explicitly.") ;;; No user options below here. @@ -155,7 +164,7 @@ directly. Instead, use `eldoc-add-command' and `eldoc-remove-command'.") This is used to determine if `eldoc-idle-delay' is changed by the user.") (defvar eldoc-message-function #'eldoc-minibuffer-message - "The function used by `eldoc-message' to display messages. + "The function used by `eldoc--message' to display messages. It should receive the same arguments as `message'.") (defun eldoc-edit-message-commands () @@ -182,8 +191,7 @@ area displays information about a function or variable in the text where point is. If point is on a documented variable, it displays the first line of that variable's doc string. Otherwise it displays the argument list of the function called in the -expression point is on." - :group 'eldoc :lighter eldoc-minor-mode-string +expression point is on." :lighter eldoc-minor-mode-string (setq eldoc-last-message nil) (cond ((not (eldoc--supported-p)) @@ -193,24 +201,23 @@ expression point is on." (eldoc-mode (when eldoc-print-after-edit (setq-local eldoc-message-commands (eldoc-edit-message-commands))) - (add-hook 'post-command-hook 'eldoc-schedule-timer nil t) - (add-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area nil t)) + (add-hook 'post-command-hook #'eldoc-schedule-timer nil t) + (add-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area nil t)) (t (kill-local-variable 'eldoc-message-commands) - (remove-hook 'post-command-hook 'eldoc-schedule-timer t) - (remove-hook 'pre-command-hook 'eldoc-pre-command-refresh-echo-area t) + (remove-hook 'post-command-hook #'eldoc-schedule-timer t) + (remove-hook 'pre-command-hook #'eldoc-pre-command-refresh-echo-area t) (when eldoc-timer (cancel-timer eldoc-timer) (setq eldoc-timer nil))))) ;;;###autoload (define-globalized-minor-mode global-eldoc-mode eldoc-mode turn-on-eldoc-mode - :group 'eldoc :initialize 'custom-initialize-delay :init-value t ;; For `read--expression', the usual global mode mechanism of ;; `change-major-mode-hook' runs in the minibuffer before - ;; `eldoc-documentation-function' is set, so `turn-on-eldoc-mode' + ;; `eldoc-documentation-strategy' is set, so `turn-on-eldoc-mode' ;; does nothing. Configure and enable eldoc from ;; `eval-expression-minibuffer-setup-hook' instead. (if global-eldoc-mode @@ -222,21 +229,24 @@ expression point is on." (defun eldoc--eval-expression-setup () ;; Setup `eldoc', similar to `emacs-lisp-mode'. FIXME: Call ;; `emacs-lisp-mode' itself? - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (cond ((<= emacs-major-version 27) + (declare-function elisp-eldoc-documentation-function "elisp-mode") + (add-function :before-until (local 'eldoc-documentation-function) + #'elisp-eldoc-documentation-function)) + (t (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) + (setq eldoc-documentation-strategy 'eldoc-documentation-default))) (eldoc-mode +1)) ;;;###autoload (defun turn-on-eldoc-mode () "Turn on `eldoc-mode' if the buffer has ElDoc support enabled. -See `eldoc-documentation-function' for more detail." +See `eldoc-documentation-strategy' for more detail." (when (eldoc--supported-p) (eldoc-mode 1))) -(defun eldoc--supported-p () - "Non-nil if an ElDoc function is set for this buffer." - (not (memq eldoc-documentation-function '(nil ignore)))) - (defun eldoc-schedule-timer () "Ensure `eldoc-timer' is running. @@ -252,7 +262,9 @@ reflect the change." (when (or eldoc-mode (and global-eldoc-mode (eldoc--supported-p))) - (eldoc-print-current-symbol-info)))))) + ;; Don't ignore, but also don't full-on signal errors + (with-demoted-errors "eldoc error: %s" + (eldoc-print-current-symbol-info)) ))))) ;; If user has changed the idle delay, update the timer. (cond ((not (= eldoc-idle-delay eldoc-current-idle-delay)) @@ -288,17 +300,18 @@ Otherwise work like `message'." (when (stringp format-string) (apply #'format-message format-string args))) (force-mode-line-update))) - (apply 'message format-string args))) + (apply #'message format-string args))) -(defun eldoc-message (&optional string) +(make-obsolete + 'eldoc-message "use `eldoc-documentation-functions' instead." "eldoc-1.1.0") +(defun eldoc-message (&optional string) (eldoc--message string)) +(defun eldoc--message (&optional string) "Display STRING as an ElDoc message if it's non-nil. Also store it in `eldoc-last-message' and return that value." (let ((omessage eldoc-last-message)) (setq eldoc-last-message string) - ;; In emacs 19.29 and later, and XEmacs 19.13 and later, all messages - ;; are recorded in a log. Do not put eldoc messages in that log since - ;; they are Legion. + ;; Do not put eldoc messages in the log since they are Legion. ;; Emacs way of preventing log messages. (let ((message-log-max nil)) (cond (eldoc-last-message @@ -311,33 +324,58 @@ Also store it in `eldoc-last-message' and return that value." (and (symbolp command) (intern-soft (symbol-name command) eldoc-message-commands))) -;; This function goes on pre-command-hook for XEmacs or when using idle -;; timers in Emacs. Motion commands clear the echo area for some reason, +;; This function goes on pre-command-hook. +;; Motion commands clear the echo area for some reason, ;; which make eldoc messages flicker or disappear just before motion ;; begins. This function reprints the last eldoc message immediately ;; before the next command executes, which does away with the flicker. ;; This doesn't seem to be required for Emacs 19.28 and earlier. +;; FIXME: The above comment suggests we don't really understand why +;; this is needed. Maybe it's not needed any more, but if it is +;; we should figure out why. (defun eldoc-pre-command-refresh-echo-area () "Reprint `eldoc-last-message' in the echo area." (and eldoc-last-message (not (minibufferp)) ;We don't use the echo area when in minibuffer. (if (and (eldoc-display-message-no-interference-p) (eldoc--message-command-p this-command)) - (eldoc-message eldoc-last-message) - ;; No need to call eldoc-message since the echo area will be cleared + (eldoc--message eldoc-last-message) + ;; No need to call eldoc--message since the echo area will be cleared ;; for us, but do note that the last-message will be gone. (setq eldoc-last-message nil)))) -;; Decide whether now is a good time to display a message. +(defvar-local eldoc--last-request-state nil + "Tuple containing information about last ElDoc request.") +(defun eldoc--request-state () + "Compute information to store in `eldoc--last-request-state'." + (list (current-buffer) (buffer-modified-tick) (point))) + (defun eldoc-display-message-p () - "Return non-nil when it is appropriate to display an ElDoc message." - (and (eldoc-display-message-no-interference-p) - ;; If this-command is non-nil while running via an idle - ;; timer, we're still in the middle of executing a command, - ;; e.g. a query-replace where it would be annoying to - ;; overwrite the echo area. - (not this-command) - (eldoc--message-command-p last-command))) + (eldoc--request-docs-p (eldoc--request-state))) +(make-obsolete 'eldoc-display-message-p + "Use `eldoc-documentation-functions' instead." + "eldoc-1.6.0") + +(defun eldoc--request-docs-p (request-state) + "Return non-nil when it is appropriate to request docs. +REQUEST-STATE is a candidate for `eldoc--last-request-state'" + (and + ;; FIXME: The original idea behind this function is to protect the + ;; Echo area from ElDoc interference, but since that is only one of + ;; the possible outlets of ElDoc, this must soon be reworked. + (eldoc-display-message-no-interference-p) + (not (and eldoc--doc-buffer + (get-buffer-window eldoc--doc-buffer) + (equal request-state + (with-current-buffer + eldoc--doc-buffer + eldoc--last-request-state)))) + ;; If this-command is non-nil while running via an idle + ;; timer, we're still in the middle of executing a command, + ;; e.g. a query-replace where it would be annoying to + ;; overwrite the echo area. + (not this-command) + (eldoc--message-command-p last-command))) ;; Check various conditions about the current environment that might make @@ -347,74 +385,408 @@ Also store it in `eldoc-last-message' and return that value." (not (or executing-kbd-macro (bound-and-true-p edebug-active)))) -;;;###autoload -(defvar eldoc-documentation-function #'ignore - "Function to call to return doc string. -The function of no args should return a one-line string for displaying -doc about a function etc. appropriate to the context around point. -It should return nil if there's no doc appropriate for the context. -Typically doc is returned if point is on a function-like name or in its -arg list. - -The result is used as is, so the function must explicitly handle -the variables `eldoc-argument-case' and `eldoc-echo-area-use-multiline-p', -and the face `eldoc-highlight-function-argument', if they are to have any -effect. - -Major modes should modify this variable using `add-function', for example: - (add-function :before-until (local \\='eldoc-documentation-function) - #\\='foo-mode-eldoc-function) -so that the global documentation function (i.e. the default value of the -variable) is taken into account if the major mode specific function does not +(defvar eldoc-documentation-functions nil + "Hook of functions that produce doc strings. + +A doc string is typically relevant if point is on a function-like +name, inside its arg list, or on any object with some associated +information. + +Each hook function is called with at least one argument CALLBACK, +a function, and decides whether to display a doc short string +about the context around point. + +- If that decision can be taken quickly, the hook function may + call CALLBACK immediately following the protocol described + below. Alternatively it may ignore CALLBACK entirely and + return either the doc string, or nil if there's no doc + appropriate for the context. + +- If the computation of said doc string (or the decision whether + there is one at all) is expensive or can't be performed + directly, the hook function should return a non-nil, non-string + value and arrange for CALLBACK to be called at a later time, + using asynchronous processes or other asynchronous mechanisms. + +To call the CALLBACK function, the hook function must pass it an +obligatory argument DOCSTRING, a string containing the +documentation, followed by an optional list of keyword-value +pairs of the form (:KEY VALUE :KEY2 VALUE2...). KEY can be: + +* `:thing', VALUE is a short string or symbol designating what is + being reported on. The documentation display engine can elect + to remove this information depending on space contraints; + +* `:face', VALUE is a symbol designating a face to use when + displaying `:thing''s value. + +Major modes should modify this hook locally, for example: + (add-hook \\='eldoc-documentation-functions #\\='foo-mode-eldoc nil t) +so that the global value (i.e. the default value of the hook) is +taken into account if the major mode specific function does not return any documentation.") -(defun eldoc-print-current-symbol-info () - "Print the text produced by `eldoc-documentation-function'." - ;; This is run from post-command-hook or some idle timer thing, - ;; so we need to be careful that errors aren't ignored. - (with-demoted-errors "eldoc error: %s" - (if (not (eldoc-display-message-p)) - ;; Erase the last message if we won't display a new one. - (when eldoc-last-message - (eldoc-message nil)) - (let ((non-essential t)) - ;; Only keep looking for the info as long as the user hasn't - ;; requested our attention. This also locally disables inhibit-quit. - (while-no-input - (eldoc-message (funcall eldoc-documentation-function))))))) - -;; If the entire line cannot fit in the echo area, the symbol name may be -;; truncated or eliminated entirely from the output to make room for the -;; description. -(defun eldoc-docstring-format-sym-doc (prefix doc &optional face) - "Combine PREFIX and DOC, and shorten the result to fit in the echo area. - -When PREFIX is a symbol, propertize its symbol name with FACE -before combining it with DOC. If FACE is not provided, just -apply the nil face. - -See also: `eldoc-echo-area-use-multiline-p'." - (when (symbolp prefix) - (setq prefix (concat (propertize (symbol-name prefix) 'face face) ": "))) - (let* ((ea-multi eldoc-echo-area-use-multiline-p) - ;; Subtract 1 from window width since emacs will not write - ;; any chars to the last column, or in later versions, will - ;; cause a wraparound and resize of the echo area. - (ea-width (1- (window-width (minibuffer-window)))) - (strip (- (+ (length prefix) (length doc)) ea-width))) - (cond ((or (<= strip 0) - (eq ea-multi t) - (and ea-multi (> (length doc) ea-width))) - (concat prefix doc)) - ((> (length doc) ea-width) - (substring (format "%s" doc) 0 ea-width)) - ((>= strip (string-match-p ":? *\\'" prefix)) - doc) +(defvar eldoc--doc-buffer nil "Buffer displaying latest ElDoc-produced docs.") + +(defun eldoc-doc-buffer (&optional interactive) + "Get latest *eldoc* help buffer. Interactively, display it." + (interactive (list t)) + (prog1 + (if (and eldoc--doc-buffer (buffer-live-p eldoc--doc-buffer)) + eldoc--doc-buffer + (setq eldoc--doc-buffer (get-buffer-create "*eldoc*"))) + (when interactive (display-buffer eldoc--doc-buffer)))) + + +(defun eldoc--handle-docs (docs) + "Display multiple DOCS in echo area. +DOCS is a list of (STRING PLIST...). It is already sorted. +Honor most of `eldoc-echo-area-use-multiline-p'." + ;; If there's nothing to report clear the echo area, but don't erase + ;; the last *eldoc* buffer. + (if (null docs) (eldoc--message nil) + (let* + ;; Otherwise, establish some parameters. + ((width (1- (window-width (minibuffer-window)))) + (val (if (and (symbolp eldoc-echo-area-use-multiline-p) + eldoc-echo-area-use-multiline-p) + max-mini-window-height + eldoc-echo-area-use-multiline-p)) + (available (cl-typecase val + (float (truncate (* (frame-height) val))) + (integer val) + (t 1))) + (things-reported-on) + (request eldoc--last-request-state) + single-doc single-doc-sym) + ;; Then, compose the contents of the `*eldoc*' buffer. + (with-current-buffer (eldoc-doc-buffer) + ;; Set doc-buffer's `eldoc--last-request-state', too + (setq eldoc--last-request-state request) + (let ((inhibit-read-only t)) + (erase-buffer) (setq buffer-read-only t) + (local-set-key "q" 'quit-window) + (cl-loop for (docs . rest) on docs + for (this-doc . plist) = docs + for thing = (plist-get plist :thing) + when thing do + (cl-pushnew thing things-reported-on) + (setq this-doc + (concat + (propertize (format "%s" thing) + 'face (plist-get plist :face)) + ": " + this-doc)) + do (insert this-doc) + when rest do (insert "\n"))) + ;; Rename the buffer. + (when things-reported-on + (rename-buffer (format "*eldoc for %s*" + (mapconcat (lambda (s) (format "%s" s)) + things-reported-on + ", "))))) + ;; Finally, output to the echo area. I'm pretty sure nicer + ;; strategies can be used here, probably by splitting this + ;; function into some `eldoc-display-functions' special hook. + (let ((echo-area-message + (cond + (;; We handle the `truncate-sym-name-if-fit' special + ;; case first, by checking if for a lot of special + ;; conditions. + (and + (eq 'truncate-sym-name-if-fit eldoc-echo-area-use-multiline-p) + (null (cdr docs)) + (setq single-doc (caar docs)) + (setq single-doc-sym + (format "%s" (plist-get (cdar docs) :thing))) + (< (length single-doc) width) + (not (string-match "\n" single-doc)) + (> (+ (length single-doc) (length single-doc-sym) 2) width)) + single-doc) + ((> available 1) + (with-current-buffer (eldoc-doc-buffer) + (cl-loop + initially + (goto-char (point-min)) + (goto-char (line-end-position (1+ available))) + for truncated = nil then t + for needed + = (let ((truncate-lines message-truncate-lines)) + (count-screen-lines (point-min) (point) t + (minibuffer-window))) + while (> needed (if truncated (1- available) available)) + do (goto-char (line-end-position (if truncated 0 -1))) + (while (and (not (bobp)) (bolp)) (goto-char (line-end-position 0))) + finally + (unless (and truncated + eldoc-prefer-doc-buffer + (get-buffer-window eldoc--doc-buffer)) + (cl-return + (concat + (buffer-substring (point-min) (point)) + (and truncated + (format + "\n(Documentation truncated. Use `%s' to see rest)" + (substitute-command-keys "\\[eldoc-doc-buffer]"))))))))) + ((= available 1) + ;; Truncate "brutally." ; FIXME: use `eldoc-prefer-doc-buffer' too? + (with-current-buffer (eldoc-doc-buffer) + (truncate-string-to-width + (buffer-substring (goto-char (point-min)) (line-end-position 1)) width)))))) + (when echo-area-message + (eldoc--message echo-area-message)))))) + +(defun eldoc-documentation-default () + "Show first doc string for item at point. +Default value for `eldoc-documentation-strategy'." + (run-hook-with-args-until-success 'eldoc-documentation-functions + (eldoc--make-callback :patient))) + +(defun eldoc--documentation-compose-1 (eagerlyp) + "Helper function for composing multiple doc strings. +If EAGERLYP is non-nil show documentation as soon as possible, +else wait for all doc strings." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback + (if eagerlyp :eager :patient))) + (str (funcall f callback))) + (if (or (null str) (stringp str)) (funcall callback str)) + nil))) + t) + +(defun eldoc-documentation-compose () + "Show multiple doc strings at once after waiting for all. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 nil)) + +(defun eldoc-documentation-compose-eagerly () + "Show multiple doc strings at once as soon as possible. +Meant as a value for `eldoc-documentation-strategy'." + (eldoc--documentation-compose-1 t)) + +(defun eldoc-documentation-enthusiast () + "Show most important doc string produced so far. +Meant as a value for `eldoc-documentation-strategy'." + (run-hook-wrapped 'eldoc-documentation-functions + (lambda (f) + (let* ((callback (eldoc--make-callback :enthusiast)) + (str (funcall f callback))) + (if (stringp str) (funcall callback str)) + nil)))) + +;; JT@2020-07-10: ElDoc is pre-loaded, so in Emacs < 28 we can't +;; make the "old" `eldoc-documentation-function' point to the new +;; `eldoc-documentation-strategy', so we do the reverse. This allows +;; for ElDoc to be loaded in those older Emacs versions and work with +;; whomever (major-modes, extensions, user) sets one or the other +;; variable. +(defmacro eldoc--documentation-strategy-defcustom + (main secondary value docstring &rest more) + "Defcustom helper macro for sorting `eldoc-documentation-strategy'." + (declare (indent 2)) + `(if (< emacs-major-version 28) + (progn + (defcustom ,secondary ,value ,docstring ,@more) + (define-obsolete-variable-alias ',main ',secondary "eldoc-1.1.0")) + (progn + (defcustom ,main ,value ,docstring ,@more) + (defvaralias ',secondary ',main ,docstring)))) + +(eldoc--documentation-strategy-defcustom eldoc-documentation-strategy + eldoc-documentation-function + #'eldoc-documentation-default + "How to collect and organize results of `eldoc-documentation-functions'. + +This variable controls how `eldoc-documentation-functions', which +specifies the sources of documentation, is queried and how its +results are organized before being displayed to the user. The +following values are allowed: + +- `eldoc-documentation-default': calls functions in the special + hook in order until one is found that produces a doc string + value. Display only that value; + +- `eldoc-documentation-compose': calls all functions in the + special hook and displays all of the resulting doc strings + together. Wait for all strings to be ready, and preserve their + relative as specified by the order of functions in the hook; + +- `eldoc-documentation-compose-eagerly': calls all functions in + the special hook and display as many of the resulting doc + strings as possible, as soon as possibl. Preserving the + relative order of doc strings; + +- `eldoc-documentation-enthusiast': calls all functions in the + special hook and displays only the most important resulting + docstring one at any given time. A function appearing first in + the special hook is considered more important. + +This variable can also be set to a function of no args that +returns something other than a string or nil and allows for some +or all of the special hook `eldoc-documentation-functions' to be +run. In that case, the strategy function should follow that +other variable's protocol closely and endeavor to display the +resulting doc strings itself. + +For backward compatibility to the \"old\" protocol, this variable +can also be set to a function that returns nil or a doc string, +depending whether or not there is documentation to display at +all." + :link '(info-link "(emacs) Lisp Doc") + :type '(radio (function-item eldoc-documentation-default) + (function-item eldoc-documentation-compose) + (function-item eldoc-documentation-compose-eagerly) + (function-item eldoc-documentation-enthusiast) + (function :tag "Other function")) + :version "28.1") + +(defun eldoc--supported-p () + "Non-nil if an ElDoc function is set for this buffer." + (and (not (memq eldoc-documentation-strategy '(nil ignore))) + (or eldoc-documentation-functions + ;; The old API had major modes set `eldoc-documentation-function' + ;; to provide eldoc support. It's impossible now to determine + ;; reliably whether the `eldoc-documentation-strategy' provides + ;; eldoc support (as in the old API) or whether it just provides + ;; a way to combine the results of the + ;; `eldoc-documentation-functions' (as in the new API). + ;; But at least if it's set buffer-locally it's a good hint that + ;; there's some eldoc support in the current buffer. + (local-variable-p 'eldoc-documentation-strategy)))) + +(defvar eldoc--enthusiasm-curbing-timer nil + "Timer used by the `eldoc-documentation-enthusiast' strategy. +When a doc string is encountered, it must endure a certain amount +of time unchallenged until it is displayed to the user. This +prevents blinking if a lower priority docstring comes in shortly +before a higher priority one.") + +(defalias 'eldoc #'eldoc-print-current-symbol-info) + +;; This variable should be unbound, but that confuses +;; `describe-symbol' for some reason. +(defvar eldoc--make-callback nil "Helper for function `eldoc--make-callback'.") + +;; JT@2020-07-08: the below docstring for the internal function +;; `eldoc--invoke-strategy' could be moved to +;; `eldoc-documentation-strategy' or thereabouts if/when we decide to +;; extend or publish the `make-callback' protocol. +(defun eldoc--make-callback (method) + "Make callback suitable for `eldoc-documentation-functions'. +The return value is a function FN whose lambda list is (STRING +&rest PLIST) and can be called by those functions. Its +responsibility is always to register the docstring STRING along +with options specified in PLIST as the documentation to display +for each particular situation. + +METHOD specifies how the callback behaves relative to other +competing elements in `eldoc-documentation-functions'. It can +have the following values: + +- `:enthusiast' says to display STRING as soon as possible if + there's no higher priority doc string; + +- `:patient' says to display STRING along with all other + competing strings but only when all of all + `eldoc-documentation-functions' have been collected; + +- `:eager' says to display STRING along with all other competing + strings so far, as soon as possible." + (funcall eldoc--make-callback method)) + +(defun eldoc--invoke-strategy () + "Invoke `eldoc-documentation-strategy' function. + +That function's job is to run the `eldoc-documentation-functions' +special hook, using the `run-hook' family of functions. ElDoc's +built-in strategy functions play along with the +`eldoc--make-callback' protocol, using it to produce callback to +feed to the functgions of `eldoc-documentation-functions'. + +Other third-party strategy functions do not use +`eldoc--make-callback'. They must find some alternate way to +produce callbacks to feed to `eldoc-documentation-function' and +should endeavour to display the docstrings eventually produced." + (let* (;; How many callbacks have been created by the strategy + ;; fucntion and passed to elements of + ;; `eldoc-documentation-functions'. + (howmany 0) + ;; How many calls to callbacks we're still waiting on. Used + ;; by `:patient'. + (want 0) + ;; The doc strings and corresponding options registered so + ;; far. + (docs-registered '())) + (cl-labels + ((register-doc + (pos string plist) + (when (and string (> (length string) 0)) + (push (cons pos (cons string plist)) docs-registered))) + (display-doc + () + (eldoc--handle-docs + (mapcar #'cdr + (setq docs-registered + (sort docs-registered + (lambda (a b) (< (car a) (car b)))))))) + (make-callback + (method) + (let ((pos (prog1 howmany (cl-incf howmany)))) + (cl-ecase method + (:enthusiast + (lambda (string &rest plist) + (when (and string (cl-loop for (p) in docs-registered + never (< p pos))) + (setq docs-registered '()) + (register-doc pos string plist) + (when (and (timerp eldoc--enthusiasm-curbing-timer) + (memq eldoc--enthusiasm-curbing-timer + timer-list)) + (cancel-timer eldoc--enthusiasm-curbing-timer)) + (setq eldoc--enthusiasm-curbing-timer + (run-at-time (unless (zerop pos) 0.3) + nil #'display-doc))) + t)) + (:patient + (cl-incf want) + (lambda (string &rest plist) + (register-doc pos string plist) + (when (zerop (cl-decf want)) (display-doc)) + t)) + (:eager + (lambda (string &rest plist) + (register-doc pos string plist) + (display-doc) + t)))))) + (let* ((eldoc--make-callback #'make-callback) + (res (funcall eldoc-documentation-strategy))) + ;; Observe the old and the new protocol: + (cond (;; Old protocol: got string, output immediately; + (stringp res) (register-doc 0 res nil) (display-doc)) + (;; Old protocol: got nil, clear the echo area; + (null res) (eldoc--message nil)) + (;; New protocol: trust callback will be called; + t)))))) + +(defun eldoc-print-current-symbol-info (&optional interactive) + "Document thing at point." + (interactive '(t)) + (let ((token (eldoc--request-state))) + (cond (interactive + (eldoc--invoke-strategy)) + ((not (eldoc--request-docs-p token)) + ;; Erase the last message if we won't display a new one. + (when eldoc-last-message + (eldoc--message nil))) (t - ;; Show the end of the partial symbol name, rather - ;; than the beginning, since the former is more likely - ;; to be unique given package namespace conventions. - (concat (substring prefix strip) doc))))) + (let ((non-essential t)) + (setq eldoc--last-request-state token) + ;; Only keep looking for the info as long as the user hasn't + ;; requested our attention. This also locally disables + ;; inhibit-quit. + (while-no-input + (eldoc--invoke-strategy))))))) ;; When point is in a sexp, the function args are not reprinted in the echo ;; area after every possible interactive command because some of them print diff --git a/lisp/emacs-lisp/find-func.el b/lisp/emacs-lisp/find-func.el index 167ead3ce02..e35db56550d 100644 --- a/lisp/emacs-lisp/find-func.el +++ b/lisp/emacs-lisp/find-func.el @@ -279,6 +279,7 @@ Interactively, prompt for LIBRARY using the one at or near point." (switch-to-buffer (find-file-noselect (find-library-name library))) (run-hooks 'find-function-after-hook))) +;;;###autoload (defun read-library-name () "Read and return a library name, defaulting to the one near point. diff --git a/lisp/emacs-lisp/float-sup.el b/lisp/emacs-lisp/float-sup.el index 50b157b16a4..d92ca5b9337 100644 --- a/lisp/emacs-lisp/float-sup.el +++ b/lisp/emacs-lisp/float-sup.el @@ -1,4 +1,4 @@ -;;; float-sup.el --- define some constants useful for floating point numbers. +;;; float-sup.el --- define some constants useful for floating point numbers. -*- lexical-binding:t -*- ;; Copyright (C) 1985-1987, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/emacs-lisp/generator.el b/lisp/emacs-lisp/generator.el index 26ab2679e22..c95c758a571 100644 --- a/lisp/emacs-lisp/generator.el +++ b/lisp/emacs-lisp/generator.el @@ -153,7 +153,7 @@ DYNAMIC-VAR bound to STATIC-VAR." (defun cps--add-state (kind body) "Create a new CPS state of KIND with BODY and return the state's name." (declare (indent 1)) - (let* ((state (cps--gensym "cps-state-%s-" kind))) + (let ((state (cps--gensym "cps-state-%s-" kind))) (push (list state body cps--cleanup-function) cps--states) (push state cps--bindings) state)) @@ -673,7 +673,7 @@ When called as a function, NAME returns an iterator value that encapsulates the state of a computation that produces a sequence of values. Callers can retrieve each value using `iter-next'." (declare (indent defun) - (debug (&define name lambda-list lambda-doc def-body)) + (debug (&define name lambda-list lambda-doc &rest sexp)) (doc-string 3)) (cl-assert lexical-binding) (let* ((parsed-body (macroexp-parse-body body)) @@ -687,14 +687,14 @@ of values. Callers can retrieve each value using `iter-next'." "Return a lambda generator. `iter-lambda' is to `iter-defun' as `lambda' is to `defun'." (declare (indent defun) - (debug (&define lambda-list lambda-doc def-body))) + (debug (&define lambda-list lambda-doc &rest sexp))) (cl-assert lexical-binding) `(lambda ,arglist ,(cps-generate-evaluator body))) (defmacro iter-make (&rest body) "Return a new iterator." - (declare (debug t)) + (declare (debug (&rest sexp))) (cps-generate-evaluator body)) (defconst iter-empty (lambda (_op _val) (signal 'iter-end-of-sequence nil)) @@ -720,7 +720,7 @@ is blocked." Evaluate BODY with VAR bound to each value from ITERATOR. Return the value with which ITERATOR finished iteration." (declare (indent 1) - (debug ((symbolp form) body))) + (debug ((symbolp form) &rest sexp))) (let ((done-symbol (cps--gensym "iter-do-iterator-done")) (condition-symbol (cps--gensym "iter-do-condition")) (it-symbol (cps--gensym "iter-do-iterator")) diff --git a/lisp/emacs-lisp/gv.el b/lisp/emacs-lisp/gv.el index 065a9688770..513bd328899 100644 --- a/lisp/emacs-lisp/gv.el +++ b/lisp/emacs-lisp/gv.el @@ -166,15 +166,25 @@ arguments as NAME. DO is a function as defined in `gv-get'." ;; (`(expand ,expander) `(gv-define-expand ,name ,expander)) (_ (message "Unknown %s declaration %S" symbol handler) nil)))) +;; Additions for `declare'. We specify the values as named aliases so +;; that `describe-variable' prints something useful; cf. Bug#40491. + +;;;###autoload +(defsubst gv--expander-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-expander args)) + +;;;###autoload +(defsubst gv--setter-defun-declaration (&rest args) + (apply #'gv--defun-declaration 'gv-setter args)) + ;;;###autoload (or (assq 'gv-expander defun-declarations-alist) - (let ((x `(gv-expander - ,(apply-partially #'gv--defun-declaration 'gv-expander)))) + (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) ;;;###autoload (or (assq 'gv-setter defun-declarations-alist) - (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) + (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) ;; (defmacro gv-define-expand (name expander) @@ -214,7 +224,7 @@ The first arg in ARGLIST (the one that receives VAL) receives an expression which can do arbitrary things, whereas the other arguments are all guaranteed to be pure and copyable. Example use: (gv-define-setter aref (v a i) \\=`(aset ,a ,i ,v))" - (declare (indent 2) (debug (&define name sexp def-body))) + (declare (indent 2) (debug (&define name :name gv-setter sexp def-body))) `(gv-define-expander ,name (lambda (do &rest args) (declare-function diff --git a/lisp/emacs-lisp/lisp-mnt.el b/lisp/emacs-lisp/lisp-mnt.el index ceb9b6bea5f..0d57bc16a3a 100644 --- a/lisp/emacs-lisp/lisp-mnt.el +++ b/lisp/emacs-lisp/lisp-mnt.el @@ -485,7 +485,18 @@ absent, return nil." (lm-with-file file (let ((start (lm-commentary-start))) (when start - (buffer-substring-no-properties start (lm-commentary-end)))))) + (replace-regexp-in-string ; Get rid of... + "[[:blank:]]*$" "" ; trailing white-space + (replace-regexp-in-string + (format "%s\\|%s\\|%s" + ;; commentary header + (concat "^;;;[[:blank:]]*\\(" + lm-commentary-header + "\\):[[:blank:]\n]*") + "^;;[[:blank:]]*" ; double semicolon prefix + "[[:blank:]\n]*\\'") ; trailing new-lines + "" (buffer-substring-no-properties + start (lm-commentary-end)))))))) (defun lm-homepage (&optional file) "Return the homepage in file FILE, or current buffer if FILE is nil." diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index fa857cd4c6b..1311d94cb01 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -456,7 +456,7 @@ This will generate compile-time constants from BINDINGS." (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; ELisp regexp grouping constructs (,(lambda (bound) @@ -511,7 +511,7 @@ This will generate compile-time constants from BINDINGS." (,(concat "\\_<:" lisp-mode-symbol-regexp "\\_>") (0 font-lock-builtin-face)) ;; ELisp and CLisp `&' keywords as types. - (,(concat "\\_<\\&" lisp-mode-symbol-regexp "\\_>") + (,(concat "\\_<&" lisp-mode-symbol-regexp "\\_>") . font-lock-type-face) ;; This is too general -- rms. ;; A user complained that he has functions whose names start with `do' @@ -611,6 +611,8 @@ Value for `adaptive-fill-function'." ;; a single docstring. Let's fix it here. (if (looking-at "\\s-+\"[^\n\"]+\"\\s-*$") "")) +;; Maybe this should be discouraged/obsoleted and users should be +;; encouraged to use `lisp-data-mode` instead. (defun lisp-mode-variables (&optional lisp-syntax keywords-case-insensitive elisp) "Common initialization routine for lisp modes. @@ -658,6 +660,14 @@ font-lock keywords will not be case sensitive." (setq-local electric-pair-skip-whitespace 'chomp) (setq-local electric-pair-open-newline-between-pairs nil)) +;;;###autoload +(define-derived-mode lisp-data-mode prog-mode "Lisp-Data" + "Major mode for buffers holding data written in Lisp syntax." + :group 'lisp + (lisp-mode-variables t t nil) + (setq-local electric-quote-string t) + (setq imenu-case-fold-search nil)) + (defun lisp-outline-level () "Lisp mode `outline-level' function." (let ((len (- (match-end 0) (match-beginning 0)))) @@ -737,7 +747,7 @@ font-lock keywords will not be case sensitive." "Keymap for ordinary Lisp mode. All commands in `lisp-mode-shared-map' are inherited by this map.") -(define-derived-mode lisp-mode prog-mode "Lisp" +(define-derived-mode lisp-mode lisp-data-mode "Lisp" "Major mode for editing Lisp code for Lisps other than GNU Emacs Lisp. Commands: Delete converts tabs to spaces as it moves back. @@ -746,10 +756,10 @@ Blank lines separate paragraphs. Semicolons start comments. \\{lisp-mode-map} Note that `run-lisp' may be used either to start an inferior Lisp job or to switch back to an existing one." - (lisp-mode-variables nil t) + (setq-local lisp-indent-function 'common-lisp-indent-function) (setq-local find-tag-default-function 'lisp-find-tag-default) (setq-local comment-start-skip - "\\(\\(^\\|[^\\\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") + "\\(\\(^\\|[^\\\n]\\)\\(\\\\\\\\\\)*\\)\\(;+\\|#|\\) *") (setq imenu-case-fold-search t)) (defun lisp-find-tag-default () @@ -946,6 +956,7 @@ is the buffer position of the start of the containing expression." ;; setting this to a number inhibits calling hook (desired-indent nil) (retry t) + whitespace-after-open-paren calculate-lisp-indent-last-sexp containing-sexp) (cond ((or (markerp parse-start) (integerp parse-start)) (goto-char parse-start)) @@ -975,6 +986,7 @@ is the buffer position of the start of the containing expression." nil ;; Innermost containing sexp found (goto-char (1+ containing-sexp)) + (setq whitespace-after-open-paren (looking-at (rx whitespace))) (if (not calculate-lisp-indent-last-sexp) ;; indent-point immediately follows open paren. ;; Don't call hook. @@ -989,9 +1001,11 @@ is the buffer position of the start of the containing expression." calculate-lisp-indent-last-sexp) ;; This is the first line to start within the containing sexp. ;; It's almost certainly a function call. - (if (= (point) calculate-lisp-indent-last-sexp) + (if (or (= (point) calculate-lisp-indent-last-sexp) + whitespace-after-open-paren) ;; Containing sexp has nothing before this line - ;; except the first element. Indent under that element. + ;; except the first element, or the first element is + ;; preceded by whitespace. Indent under that element. nil ;; Skip the first element, find start of second (the first ;; argument of the function call) and indent under. diff --git a/lisp/emacs-lisp/map.el b/lisp/emacs-lisp/map.el index 67f5b3cf24e..9c23344baca 100644 --- a/lisp/emacs-lisp/map.el +++ b/lisp/emacs-lisp/map.el @@ -4,7 +4,7 @@ ;; Author: Nicolas Petton <nicolas@petton.fr> ;; Keywords: convenience, map, hash-table, alist, array -;; Version: 2.0 +;; Version: 2.1 ;; Package-Requires: ((emacs "25")) ;; Package: map @@ -56,8 +56,10 @@ evaluated and searched for in the map. The match fails if for any KEY found in the map, the corresponding PAT doesn't match the value associated to the KEY. -Each element can also be a SYMBOL, which is an abbreviation of a (KEY -PAT) tuple of the form (\\='SYMBOL SYMBOL). +Each element can also be a SYMBOL, which is an abbreviation of +a (KEY PAT) tuple of the form (\\='SYMBOL SYMBOL). When SYMBOL +is a keyword, it is an abbreviation of the form (:SYMBOL SYMBOL), +useful for binding plist values. Keys in ARGS not found in the map are ignored, and the match doesn't fail." @@ -486,9 +488,12 @@ Example: (defun map--make-pcase-bindings (args) "Return a list of pcase bindings from ARGS to the elements of a map." (seq-map (lambda (elt) - (if (consp elt) - `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt)) - `(app (pcase--flip map-elt ',elt) ,elt))) + (cond ((consp elt) + `(app (pcase--flip map-elt ,(car elt)) ,(cadr elt))) + ((keywordp elt) + (let ((var (intern (substring (symbol-name elt) 1)))) + `(app (pcase--flip map-elt ,elt) ,var))) + (t `(app (pcase--flip map-elt ',elt) ,elt)))) args)) (defun map--make-pcase-patterns (args) diff --git a/lisp/emacs-lisp/package.el b/lisp/emacs-lisp/package.el index 7d6be3cf4e2..e6f54d206d8 100644 --- a/lisp/emacs-lisp/package.el +++ b/lisp/emacs-lisp/package.el @@ -397,6 +397,26 @@ synchronously." :type 'boolean :version "25.1") +(defcustom package-name-column-width 30 + "Column width for the Package name in the package menu." + :type 'number + :version "28.1") + +(defcustom package-version-column-width 14 + "Column width for the Package version in the package menu." + :type 'number + :version "28.1") + +(defcustom package-status-column-width 12 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + +(defcustom package-archive-column-width 8 + "Column width for the Package status in the package menu." + :type 'number + :version "28.1") + ;;; `package-desc' object definition ;; This is the struct used internally to represent packages. @@ -421,9 +441,9 @@ synchronously." &aux (name (intern name-string)) (version (version-to-list version-string)) - (reqs (mapcar #'(lambda (elt) - (list (car elt) - (version-to-list (cadr elt)))) + (reqs (mapcar (lambda (elt) + (list (car elt) + (version-to-list (cadr elt)))) (if (eq 'quote (car requirements)) (nth 1 requirements) requirements))) @@ -670,9 +690,9 @@ updates `package-alist'." (progn (package-load-all-descriptors) package-alist))) -(defun define-package (_name-string _version-string - &optional _docstring _requirements - &rest _extra-properties) +(defun define-package ( _name-string _version-string + &optional _docstring _requirements + &rest _extra-properties) "Define a new package. NAME-STRING is the name of the package, as a string. VERSION-STRING is the version of the package, as a string. @@ -798,7 +818,7 @@ correspond to previously loaded files (those returned by ;; FIXME: not the friendliest, but simple. (require 'info) (info-initialize) - (push pkg-dir Info-directory-list)) + (add-to-list 'Info-directory-list pkg-dir)) (push name package-activated-list) ;; Don't return nil. t))) @@ -926,7 +946,6 @@ untar into a directory named DIR; otherwise, signal an error." (if (> (length file-list) 1) 'tar 'single)))) ('tar (make-directory package-user-dir t) - ;; FIXME: should we delete PKG-DIR if it exists? (let* ((default-directory (file-name-as-directory package-user-dir))) (package-untar-buffer dirname))) ('single @@ -1200,8 +1219,8 @@ The return result is a `package-desc'." cipher-algorithm digest-algorithm compress-algorithm)) -(declare-function epg-verify-string "epg" (context signature - &optional signed-text)) +(declare-function epg-verify-string "epg" ( context signature + &optional signed-text)) (declare-function epg-context-result-for "epg" (context name)) (declare-function epg-signature-status "epg" (signature) t) (declare-function epg-signature-to-string "epg" (signature)) @@ -2082,7 +2101,8 @@ to install it but still mark it as selected." (package-compute-transaction () (list (list pkg)))))) (progn (package-download-transaction transaction) - (package--quickstart-maybe-refresh)) + (package--quickstart-maybe-refresh) + (message "Package `%s' installed." name)) (message "`%s' is already installed" name)))) (defun package-strip-rcs-id (str) @@ -2377,18 +2397,9 @@ The description is read from the installed package files." result ;; Look for Commentary header. - (let ((mainsrcfile (expand-file-name (format "%s.el" (package-desc-name desc)) - srcdir))) - (when (file-readable-p mainsrcfile) - (with-temp-buffer - (insert (or (lm-commentary mainsrcfile) "")) - (goto-char (point-min)) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")) - (buffer-string)))) - ))) + (lm-commentary (expand-file-name + (format "%s.el" (package-desc-name desc)) srcdir)) + ""))) (defun describe-package-1 (pkg) "Insert the package description for PKG. @@ -2583,16 +2594,10 @@ Helper function for `describe-package'." (if built-in ;; For built-in packages, get the description from the ;; Commentary header. - (let ((fn (locate-file (format "%s.el" name) load-path - load-file-rep-suffixes)) - (opoint (point))) - (insert (or (lm-commentary fn) "")) - (save-excursion - (goto-char opoint) - (when (re-search-forward "^;;; Commentary:\n" nil t) - (replace-match "")) - (while (re-search-forward "^\\(;+ ?\\)" nil t) - (replace-match "")))) + (insert (or (lm-commentary (locate-file (format "%s.el" name) + load-path + load-file-rep-suffixes)) + "")) (if (package-installed-p desc) ;; For installed packages, get the description from the @@ -2695,15 +2700,19 @@ either a full name or nil, and EMAIL is a valid email address." (define-key map "i" 'package-menu-mark-install) (define-key map "U" 'package-menu-mark-upgrades) (define-key map "r" 'revert-buffer) - (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) - (define-key map (kbd "/ n") 'package-menu-filter-by-name) - (define-key map (kbd "/ /") 'package-menu-clear-filter) (define-key map "~" 'package-menu-mark-obsolete-for-deletion) (define-key map "x" 'package-menu-execute) (define-key map "h" 'package-menu-quick-help) (define-key map "H" #'package-menu-hide-package) (define-key map "?" 'package-menu-describe-package) (define-key map "(" #'package-menu-toggle-hiding) + (define-key map (kbd "/ /") 'package-menu-clear-filter) + (define-key map (kbd "/ a") 'package-menu-filter-by-archive) + (define-key map (kbd "/ k") 'package-menu-filter-by-keyword) + (define-key map (kbd "/ n") 'package-menu-filter-by-name) + (define-key map (kbd "/ s") 'package-menu-filter-by-status) + (define-key map (kbd "/ v") 'package-menu-filter-by-version) + (define-key map (kbd "/ m") 'package-menu-filter-marked) map) "Local keymap for `package-menu-mode' buffers.") @@ -2729,8 +2738,12 @@ either a full name or nil, and EMAIL is a valid email address." "--" ("Filter Packages" + ["Filter by Archive" package-menu-filter-by-archive :help "Filter packages by archive"] ["Filter by Keyword" package-menu-filter-by-keyword :help "Filter packages by keyword"] ["Filter by Name" package-menu-filter-by-name :help "Filter packages by name"] + ["Filter by Status" package-menu-filter-by-status :help "Filter packages by status"] + ["Filter by Version" package-menu-filter-by-version :help "Filter packages by version"] + ["Filter Marked" package-menu-filter-marked :help "Filter packages marked for upgrade"] ["Clear Filter" package-menu-clear-filter :help "Clear package list filter"]) ["Hide by Regexp" package-menu-hide-package :help "Hide all packages matching a regexp"] @@ -2757,11 +2770,11 @@ Letters do not insert themselves; instead, they are commands. (package-menu--transaction-status package-menu--transaction-status))) (setq tabulated-list-format - `[("Package" 18 package-menu--name-predicate) - ("Version" 13 package-menu--version-predicate) - ("Status" 10 package-menu--status-predicate) + `[("Package" ,package-name-column-width package-menu--name-predicate) + ("Version" ,package-version-column-width package-menu--version-predicate) + ("Status" ,package-status-column-width package-menu--status-predicate) ,@(if (cdr package-archives) - '(("Archive" 10 package-menu--archive-predicate))) + `(("Archive" ,package-archive-column-width package-menu--archive-predicate))) ("Description" 0 package-menu--description-predicate)]) (setq tabulated-list-padding 2) (setq tabulated-list-sort-key (cons "Status" nil)) @@ -3040,8 +3053,21 @@ When none are given, the package matches." found) t)) -(defun package-menu--generate (remember-pos packages &optional keywords) - "Populate the Package Menu. +(defun package-menu--display (remember-pos suffix) + "Display the Package Menu. +If REMEMBER-POS is non-nil, keep point on the same entry. + +If SUFFIX is non-nil, append that to \"Package\" for the first +column in the header line." + (setf (car (aref tabulated-list-format 0)) + (if suffix + (concat "Package[" suffix "]") + "Package")) + (tabulated-list-init-header) + (tabulated-list-print remember-pos)) + +(defun package-menu--generate (remember-pos &optional packages keywords) + "Populate and display the Package Menu. If REMEMBER-POS is non-nil, keep point on the same entry. PACKAGES should be t, which means to display all known packages, or a list of package names (symbols) to display. @@ -3049,13 +3075,10 @@ or a list of package names (symbols) to display. With KEYWORDS given, only packages with those keywords are shown." (package-menu--refresh packages keywords) - (setf (car (aref tabulated-list-format 0)) - (if keywords - (let ((filters (mapconcat #'identity keywords ","))) - (concat "Package[" filters "]")) - "Package")) - (tabulated-list-init-header) - (tabulated-list-print remember-pos)) + (package-menu--display remember-pos + (when keywords + (let ((filters (mapconcat #'identity keywords ","))) + (concat "Package[" filters "]"))))) (defun package-menu--print-info (pkg) "Return a package entry suitable for `tabulated-list-entries'. @@ -3699,48 +3722,192 @@ shown." (select-window win) (switch-to-buffer buf)))) +(defun package-menu--filter-by (predicate suffix) + "Filter \"*Packages*\" buffer by PREDICATE and add SUFFIX to header. +PREDICATE is a function which will be called with one argument, a +`package-desc' object, and returns t if that object should be +listed in the Package Menu. + +SUFFIX is passed on to `package-menu--display' and is added to +the header line of the first column." + ;; Update `tabulated-list-entries' so that it contains all + ;; packages before searching. + (package-menu--refresh t nil) + (let (found-entries) + (dolist (entry tabulated-list-entries) + (when (funcall predicate (car entry)) + (push entry found-entries))) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t suffix)) + (user-error "No packages found")))) + +(defun package-menu-filter-by-archive (archive) + "Filter the \"*Packages*\" buffer by ARCHIVE. +Display only packages from package archive ARCHIVE. + +When called interactively, prompt for ARCHIVE, which can be a +comma-separated string. If ARCHIVE is empty, show all packages. + +When called from Lisp, ARCHIVE can be a string or a list of +strings. If ARCHIVE is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Filter by archive (comma separated): " + (mapcar #'car package-archives)))) + (package--ensure-package-menu-mode) + (let ((re (if (listp archive) + (regexp-opt archive) + archive))) + (package-menu--filter-by (lambda (pkg-desc) + (let ((pkg-archive (package-desc-archive pkg-desc))) + (and pkg-archive + (string-match-p re pkg-archive)))) + (concat "archive:" (if (listp archive) + (string-join archive ",") + archive))))) + (defun package-menu-filter-by-keyword (keyword) "Filter the \"*Packages*\" buffer by KEYWORD. -Show only those items that relate to the specified KEYWORD. - -KEYWORD can be a string or a list of strings. If it is a list, a -package will be displayed if it matches any of the keywords. -Interactively, it is a list of strings separated by commas. - -KEYWORD can also be used to filter by status or archive name by -using keywords like \"arc:gnu\" and \"status:available\". -Statuses available include \"incompat\", \"available\", -\"built-in\" and \"installed\"." - (interactive - (list (completing-read-multiple - "Keywords (comma separated): " (package-all-keywords)))) +Display only packages with specified KEYWORD. + +When called interactively, prompt for KEYWORD, which can be a +comma-separated string. If KEYWORD is empty, show all packages. + +When called from Lisp, KEYWORD can be a string or a list of +strings. If KEYWORD is nil or the empty string, show all +packages." + (interactive (list (completing-read-multiple + "Keywords (comma separated): " + (package-all-keywords)))) + (when (stringp keyword) + (setq keyword (list keyword))) (package--ensure-package-menu-mode) - (package-show-package-list t (if (stringp keyword) - (list keyword) - keyword))) + (if (not keyword) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (package--has-keyword-p pkg-desc keyword)) + (concat "keyword:" (string-join keyword ","))))) (define-obsolete-function-alias 'package-menu-filter #'package-menu-filter-by-keyword "27.1") (defun package-menu-filter-by-name (name) - "Filter the \"*Packages*\" buffer by NAME. -Show only those items whose name matches the regular expression -NAME. If NAME is nil or the empty string, show all packages." - (interactive (list (read-from-minibuffer "Filter by name (regexp): "))) + "Filter the \"*Packages*\" buffer by NAME regexp. +Display only packages with name that matches regexp NAME. + +When called interactively, prompt for NAME. + +If NAME is nil or the empty string, show all packages." + (interactive (list (read-regexp "Filter by name (regexp)"))) (package--ensure-package-menu-mode) (if (or (not name) (string-empty-p name)) - (package-show-package-list t nil) - ;; Update `tabulated-list-entries' so that it contains all - ;; packages before searching. - (package-menu--refresh t nil) - (let (matched) - (dolist (entry tabulated-list-entries) - (let* ((pkg-name (package-desc-name (car entry)))) - (when (string-match name (symbol-name pkg-name)) - (push pkg-name matched)))) - (if matched - (package-show-package-list matched nil) - (user-error "No packages found"))))) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p name (symbol-name + (package-desc-name pkg-desc)))) + (format "name:%s" name)))) + +(defun package-menu-filter-by-status (status) + "Filter the \"*Packages*\" buffer by STATUS. +Display only packages with specified STATUS. + +When called interactively, prompt for STATUS, which can be a +comma-separated string. If STATUS is empty, show all packages. + +When called from Lisp, STATUS can be a string or a list of +strings. If STATUS is nil or the empty string, show all +packages." + (interactive (list (completing-read "Filter by status: " + '("avail-obso" + "available" + "built-in" + "dependency" + "disabled" + "external" + "held" + "incompat" + "installed" + "new" + "unsigned")))) + (package--ensure-package-menu-mode) + (if (or (not status) (string-empty-p status)) + (package-menu--generate t t) + (package-menu--filter-by (lambda (pkg-desc) + (string-match-p status (package-desc-status pkg-desc))) + (format "status:%s" status)))) + +(defun package-menu-filter-by-version (version predicate) + "Filter the \"*Packages*\" buffer by VERSION and PREDICATE. +Display only packages with a matching version. + +When called interactively, prompt for one of the qualifiers `<', +`>' or `=', and a package version. Show only packages that has a +lower (`<'), equal (`=') or higher (`>') version than the +specified one. + +When called from Lisp, VERSION should be a version string and +PREDICATE should be the symbol `=', `<' or `>'. + +If VERSION is nil or the empty string, show all packages." + (interactive (let ((choice (intern + (char-to-string + (read-char-choice + "Filter by version? [Type =, <, > or q] " + '(?< ?> ?= ?q)))))) + (if (eq choice 'q) + '(quit nil) + (list (read-from-minibuffer + (concat "Filter by version (" + (pcase choice + ('= "= equal to") + ('< "< less than") + ('> "> greater than")) + "): ")) + choice)))) + (unless (equal predicate 'quit) + (if (or (not version) (string-empty-p version)) + (package-menu--generate t t) + (package-menu--filter-by + (let ((fun (pcase predicate + ('= #'version-list-=) + ('< #'version-list-<) + ('> (lambda (a b) (not (version-list-<= a b)))) + (_ (error "Unknown predicate: %s" predicate)))) + (ver (version-to-list version))) + (lambda (pkg-desc) + (funcall fun (package-desc-version pkg-desc) ver))) + (format "versions:%s%s" predicate version))))) + +(defun package-menu-filter-marked () + "Filter \"*Packages*\" buffer by non-empty upgrade mark. +Unlike other filters, this leaves the marks intact." + (interactive) + (package--ensure-package-menu-mode) + (widen) + (let (found-entries mark pkg-id entry marks) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (char-after)) + (unless (eq mark ?\s) + (setq pkg-id (tabulated-list-get-id)) + (setq entry (package-menu--print-info-simple pkg-id)) + (push entry found-entries) + ;; remember the mark + (push (cons pkg-id mark) marks)) + (forward-line)) + (if found-entries + (progn + (setq tabulated-list-entries found-entries) + (package-menu--display t nil) + ;; redo the marks, but we must remember the marks!! + (goto-char (point-min)) + (while (not (eobp)) + (setq mark (cdr (assq (tabulated-list-get-id) marks))) + (tabulated-list-put-tag (char-to-string mark) t))) + (user-error "No packages found"))))) (defun package-menu-clear-filter () "Clear any filter currently applied to the \"*Packages*\" buffer." @@ -3789,6 +3956,7 @@ The return value is a string (or nil in case we can't find it)." (or (lm-header "package-version") (lm-header "version"))))))))) + ;;;; Quickstart: precompute activation actions for faster start up. ;; Activating packages via `package-initialize' is costly: for N installed diff --git a/lisp/emacs-lisp/pcase.el b/lisp/emacs-lisp/pcase.el index 36b93fa7ac5..a8ce23284c4 100644 --- a/lisp/emacs-lisp/pcase.el +++ b/lisp/emacs-lisp/pcase.el @@ -344,7 +344,8 @@ of the elements of LIST is performed as if by `pcase-let'. (seen '()) (codegen (lambda (code vars) - (let ((prev (assq code seen))) + (let ((vars (pcase--fgrep vars code)) + (prev (assq code seen))) (if (not prev) (let ((res (pcase-codegen code vars))) (push (list code vars res) seen) @@ -398,7 +399,10 @@ of the elements of LIST is performed as if by `pcase-let'. (if (pcase--small-branch-p (cdr case)) ;; Don't bother sharing multiple ;; occurrences of this leaf since it's small. - #'pcase-codegen codegen) + (lambda (code vars) + (pcase-codegen code + (pcase--fgrep vars code))) + codegen) (cdr case) vars)))) cases)))) @@ -687,14 +691,22 @@ MATCH is the pattern that needs to be matched, of the form: '(nil . :pcase--fail) '(:pcase--fail . nil)))))) -(defun pcase--fgrep (vars sexp) - "Check which of the symbols VARS appear in SEXP." +(defun pcase--fgrep (bindings sexp) + "Return those of the BINDINGS which might be used in SEXP." (let ((res '())) - (while (consp sexp) - (dolist (var (pcase--fgrep vars (pop sexp))) - (unless (memq var res) (push var res)))) - (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) - res)) + (while (and (consp sexp) bindings) + (dolist (binding (pcase--fgrep bindings (pop sexp))) + (push binding res) + (setq bindings (remove binding bindings)))) + (if (vectorp sexp) + ;; With backquote, code can appear within vectors as well. + ;; This wouldn't be needed if we `macroexpand-all' before + ;; calling pcase--fgrep, OTOH. + (pcase--fgrep bindings (mapcar #'identity sexp)) + (let ((tmp (assq sexp bindings))) + (if tmp + (cons tmp res) + res))))) (defun pcase--self-quoting-p (upat) (or (keywordp upat) (integerp upat) (stringp upat))) @@ -734,13 +746,11 @@ MATCH is the pattern that needs to be matched, of the form: "Build a function call to FUN with arg ARG." (if (symbolp fun) `(,fun ,arg) - (let* (;; `vs' is an upper bound on the vars we need. - (vs (pcase--fgrep (mapcar #'car vars) fun)) - (env (mapcar (lambda (var) - (list var (cdr (assq var vars)))) - vs)) + (let* (;; `env' is an upper bound on the bindings we need. + (env (mapcar (lambda (x) (list (car x) (cdr x))) + (pcase--fgrep vars fun))) (call (progn - (when (memq arg vs) + (when (assq arg env) ;; `arg' is shadowed by `env'. (let ((newsym (gensym "x"))) (push (list newsym arg) env) @@ -748,7 +758,7 @@ MATCH is the pattern that needs to be matched, of the form: (if (functionp fun) `(funcall #',fun ,arg) `(,@fun ,arg))))) - (if (null vs) + (if (null env) call ;; Let's not replace `vars' in `fun' since it's ;; too difficult to do it right, instead just @@ -759,10 +769,12 @@ MATCH is the pattern that needs to be matched, of the form: "Build an expression that will evaluate EXP." (let* ((found (assq exp vars))) (if found (cdr found) - (let* ((vs (pcase--fgrep (mapcar #'car vars) exp)) - (env (mapcar (lambda (v) (list v (cdr (assq v vars)))) - vs))) - (if env (macroexp-let* env exp) exp))))) + (let* ((env (pcase--fgrep vars exp))) + (if env + (macroexp-let* (mapcar (lambda (x) (list (car x) (cdr x))) + env) + exp) + exp))))) ;; It's very tempting to use `pcase' below, tho obviously, it'd create ;; bootstrapping problems. diff --git a/lisp/emacs-lisp/rx.el b/lisp/emacs-lisp/rx.el index aa4b2addd47..88bb0a8bd6c 100644 --- a/lisp/emacs-lisp/rx.el +++ b/lisp/emacs-lisp/rx.el @@ -1381,7 +1381,7 @@ To make local rx extensions, use `rx-let' for `rx', For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" - (declare (indent 1)) + (declare (indent defun)) `(eval-and-compile (put ',name 'rx-definition ',(rx--make-binding name definition)) ',name)) diff --git a/lisp/emacs-lisp/seq.el b/lisp/emacs-lisp/seq.el index e3037a71901..4c1a1797adc 100644 --- a/lisp/emacs-lisp/seq.el +++ b/lisp/emacs-lisp/seq.el @@ -348,6 +348,7 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called." (setq acc (funcall function acc elt))) acc))) +;;;###autoload (cl-defgeneric seq-every-p (pred sequence) "Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE." (catch 'seq--break diff --git a/lisp/emacs-lisp/smie.el b/lisp/emacs-lisp/smie.el index 60d8fa591e9..38a7b8b54c9 100644 --- a/lisp/emacs-lisp/smie.el +++ b/lisp/emacs-lisp/smie.el @@ -52,6 +52,13 @@ ;; error because the parser just automatically does something. Better yet, ;; we can afford to use a sloppy grammar. +;; The benefits of this approach were presented in the following article, +;; which includes a kind of tutorial to get started with SMIE: +;; +;; SMIE: Weakness is Power! Auto-indentation with incomplete information +;; Stefan Monnier, <Programming> Journal 2020, volumn 5, issue 1. +;; doi: 10.22152/programming-journal.org/2020/5/1 + ;; A good background to understand the development (especially the parts ;; building the 2D precedence tables and then computing the precedence levels ;; from it) can be found in pages 187-194 of "Parsing techniques" by Dick Grune @@ -63,6 +70,7 @@ ;; Since then, some of that code has been beaten into submission, but the ;; smie-indent-keyword is still pretty obscure. + ;; Conflict resolution: ;; ;; - One source of conflicts is when you have: @@ -1356,9 +1364,9 @@ Only meaningful when called from within `smie-rules-function'." (funcall smie-rules-function :elem 'basic)) smie-indent-basic)) -(defun smie-indent--rule (method token - ;; FIXME: Too many parameters. - &optional after parent base-pos) +(defun smie-indent--rule ( method token + ;; FIXME: Too many parameters. + &optional after parent base-pos) "Compute indentation column according to `smie-rules-function'. METHOD and TOKEN are passed to `smie-rules-function'. AFTER is the position after TOKEN, if known. diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el index 044c9aada0d..9f96ac50d1c 100644 --- a/lisp/emacs-lisp/subr-x.el +++ b/lisp/emacs-lisp/subr-x.el @@ -236,6 +236,15 @@ REGEXP defaults to \"[ \\t\\n\\r]+\"." TRIM-LEFT and TRIM-RIGHT default to \"[ \\t\\n\\r]+\"." (string-trim-left (string-trim-right string trim-right) trim-left)) +;;;###autoload +(defun string-truncate-left (string length) + "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." + (let ((strlen (length string))) + (if (<= strlen length) + string + (setq length (max 0 (- length 3))) + (concat "..." (substring string (max 0 (- strlen 1 length))))))) + (defsubst string-blank-p (string) "Check whether STRING is either empty or only whitespace. The following characters count as whitespace here: space, tab, newline and diff --git a/lisp/emacs-lisp/syntax.el b/lisp/emacs-lisp/syntax.el index 11cc1988b1f..ce495af95bc 100644 --- a/lisp/emacs-lisp/syntax.el +++ b/lisp/emacs-lisp/syntax.el @@ -63,9 +63,10 @@ override the buffer's syntax table for special syntactic constructs that cannot be handled just by the buffer's syntax-table. The specified function may call `syntax-ppss' on any position -before END, but it should not call `syntax-ppss-flush-cache', -which means that it should not call `syntax-ppss' on some -position and later modify the buffer on some earlier position.") +before END, but if it calls `syntax-ppss' on some +position and later modifies the buffer on some earlier position, +then it is its responsability to call `syntax-ppss-flush-cache' to flush +the now obsolete ppss info from the cache.") (defvar syntax-propertize-chunk-size 500) @@ -138,14 +139,28 @@ delimiter or an Escaped or Char-quoted character.")) (point-max)))) (cons beg end)) -(defun syntax-propertize--shift-groups (re n) - (replace-regexp-in-string - "\\\\(\\?\\([0-9]+\\):" - (lambda (s) - (replace-match - (number-to-string (+ n (string-to-number (match-string 1 s)))) - t t s 1)) - re t t)) +(defun syntax-propertize--shift-groups-and-backrefs (re n) + (let ((new-re (replace-regexp-in-string + "\\\\(\\?\\([0-9]+\\):" + (lambda (s) + (replace-match + (number-to-string + (+ n (string-to-number (match-string 1 s)))) + t t s 1)) + re t t)) + (pos 0)) + (while (string-match "\\\\\\([0-9]+\\)" new-re pos) + (setq pos (+ 1 (match-beginning 1))) + (when (save-match-data + ;; With \N, the \ must be in a subregexp context, i.e., + ;; not in a character class or in a \{\} repetition. + (subregexp-context-p new-re (match-beginning 0))) + (let ((shifted (+ n (string-to-number (match-string 1 new-re))))) + (when (> shifted 9) + (error "There may be at most nine back-references")) + (setq new-re (replace-match (number-to-string shifted) + t t new-re 1))))) + new-re)) (defmacro syntax-propertize-precompile-rules (&rest rules) "Return a precompiled form of RULES to pass to `syntax-propertize-rules'. @@ -189,7 +204,8 @@ for subsequent HIGHLIGHTs. Also SYNTAX is free to move point, in which case RULES may not be applied to some parts of the text or may be applied several times to other parts. -Note: back-references in REGEXPs do not work." +Note: There may be at most nine back-references in the REGEXPs of +all RULES in total." (declare (debug (&rest &or symbolp ;FIXME: edebug this eval step. (form &rest (numberp @@ -218,7 +234,7 @@ Note: back-references in REGEXPs do not work." ;; tell when *this* match 0 has succeeded. (cl-incf offset) (setq re (concat "\\(" re "\\)"))) - (setq re (syntax-propertize--shift-groups re offset)) + (setq re (syntax-propertize--shift-groups-and-backrefs re offset)) (let ((code '()) (condition (cond @@ -320,6 +336,11 @@ END) suitable for `syntax-propertize-function'." (defvar-local syntax-ppss-table nil "Syntax-table to use during `syntax-ppss', if any.") +(defvar-local syntax-propertize--inhibit-flush nil + "If non-nil, `syntax-ppss-flush-cache' only flushes the ppss cache. +Otherwise it flushes both the ppss cache and the properties +set by `syntax-propertize'") + (defun syntax-propertize (pos) "Ensure that syntax-table properties are set until POS (a buffer point)." (when (< syntax-propertize--done pos) @@ -345,23 +366,27 @@ END) suitable for `syntax-propertize-function'." (end (max pos (min (point-max) (+ start syntax-propertize-chunk-size)))) - (funs syntax-propertize-extend-region-functions)) - (while funs - (let ((new (funcall (pop funs) start end)) - ;; Avoid recursion! - (syntax-propertize--done most-positive-fixnum)) - (if (or (null new) - (and (>= (car new) start) (<= (cdr new) end))) - nil - (setq start (car new)) - (setq end (cdr new)) - ;; If there's been a change, we should go through the - ;; list again since this new position may - ;; warrant a different answer from one of the funs we've - ;; already seen. - (unless (eq funs - (cdr syntax-propertize-extend-region-functions)) - (setq funs syntax-propertize-extend-region-functions))))) + (first t) + (repeat t)) + (while repeat + (setq repeat nil) + (run-hook-wrapped + 'syntax-propertize-extend-region-functions + (lambda (f) + (let ((new (funcall f start end)) + ;; Avoid recursion! + (syntax-propertize--done most-positive-fixnum)) + (if (or (null new) + (and (>= (car new) start) (<= (cdr new) end))) + nil + (setq start (car new)) + (setq end (cdr new)) + ;; If there's been a change, we should go through the + ;; list again since this new position may + ;; warrant a different answer from one of the funs we've + ;; already seen. + (unless first (setq repeat t)))) + (setq first nil)))) ;; Flush ppss cache between the original value of `start' and that ;; set above by syntax-propertize-extend-region-functions. (syntax-ppss-flush-cache start) @@ -371,8 +396,13 @@ END) suitable for `syntax-propertize-function'." ;; (message "syntax-propertizing from %s to %s" start end) (remove-text-properties start end '(syntax-table nil syntax-multiline nil)) - ;; Avoid recursion! - (let ((syntax-propertize--done most-positive-fixnum)) + ;; Make sure we only let-bind it buffer-locally. + (make-local-variable 'syntax-propertize--inhibit-flush) + ;; Let-bind `syntax-propertize--done' to avoid infinite recursion! + (let ((syntax-propertize--done most-positive-fixnum) + ;; Let `syntax-propertize-function' call + ;; `syntax-ppss-flush-cache' without worries. + (syntax-propertize--inhibit-flush t)) (funcall syntax-propertize-function start end))))))))) ;;; Link syntax-propertize with syntax.c. @@ -451,7 +481,8 @@ These are valid when the buffer has no restriction.") (defun syntax-ppss-flush-cache (beg &rest ignored) "Flush the cache of `syntax-ppss' starting at position BEG." ;; Set syntax-propertize to refontify anything past beg. - (setq syntax-propertize--done (min beg syntax-propertize--done)) + (unless syntax-propertize--inhibit-flush + (setq syntax-propertize--done (min beg syntax-propertize--done))) ;; Flush invalid cache entries. (dolist (cell (list syntax-ppss-wide syntax-ppss-narrow)) (pcase cell diff --git a/lisp/emacs-lisp/tabulated-list.el b/lisp/emacs-lisp/tabulated-list.el index 501cc3a29e0..b13f609f882 100644 --- a/lisp/emacs-lisp/tabulated-list.el +++ b/lisp/emacs-lisp/tabulated-list.el @@ -547,10 +547,10 @@ Return the column number after insertion." ;; Don't truncate to `width' if the next column is align-right ;; and has some space left, truncate to `available-space' instead. (when (and not-last-col - (> label-width available-space) - (setq label (truncate-string-to-width - label available-space nil nil t t) - label-width available-space))) + (> label-width available-space)) + (setq label (truncate-string-to-width + label available-space nil nil t t) + label-width available-space)) (setq label (bidi-string-mark-left-to-right label)) (when (and right-align (> width label-width)) (let ((shift (- width label-width))) diff --git a/lisp/emacs-lisp/text-property-search.el b/lisp/emacs-lisp/text-property-search.el index b6e98f59a7a..61bd98d3cfe 100644 --- a/lisp/emacs-lisp/text-property-search.el +++ b/lisp/emacs-lisp/text-property-search.el @@ -137,11 +137,19 @@ and if a matching region is found, moves point to its beginning." nil) ;; We're standing in the property we're looking for, so find the ;; end. - ((and (text-property--match-p - value (get-text-property (1- (point)) property) - predicate) - (not not-current)) - (text-property--find-end-backward (1- (point)) property value predicate)) + ((text-property--match-p + value (get-text-property (1- (point)) property) + predicate) + (let ((origin (point)) + (match (text-property--find-end-backward + (1- (point)) property value predicate))) + ;; When we want to ignore the current element, then repeat the + ;; search if we haven't moved out of it yet. + (if (and not-current + (equal (get-text-property (point) property) + (get-text-property origin property))) + (text-property-search-backward property value predicate) + match))) (t (let ((origin (point)) (ended nil) diff --git a/lisp/emacs-lisp/timer-list.el b/lisp/emacs-lisp/timer-list.el index 4fa31f32673..00d09696d2a 100644 --- a/lisp/emacs-lisp/timer-list.el +++ b/lisp/emacs-lisp/timer-list.el @@ -32,41 +32,49 @@ "List all timers in a buffer." (interactive) (pop-to-buffer-same-window (get-buffer-create "*timer-list*")) - (let ((inhibit-read-only t)) - (erase-buffer) - (timer-list-mode) - (dolist (timer (append timer-list timer-idle-list)) - (insert (format "%4s %10s %8s %s" - ;; Idle. - (if (aref timer 7) "*" " ") - ;; Next time. - (let ((time (list (aref timer 1) - (aref timer 2) - (aref timer 3)))) - (format "%.2f" - (float-time - (if (aref timer 7) - time - (time-subtract time nil))))) - ;; Repeat. - (let ((repeat (aref timer 4))) - (cond - ((numberp repeat) - (format "%.2f" (/ repeat 60))) - ((null repeat) - "-") - (t - (format "%s" repeat)))) - ;; Function. - (let ((cl-print-compiled 'static) - (cl-print-compiled-button nil) - (print-escape-newlines t)) - (cl-prin1-to-string (aref timer 5))))) - (put-text-property (line-beginning-position) - (1+ (line-beginning-position)) - 'timer timer) - (insert "\n"))) - (goto-char (point-min))) + (timer-list-mode) + (tabulated-list-init-header) + (setq tabulated-list-entries + (mapcar + (lambda (timer) + (list + nil + `[ ;; Idle. + ,(propertize + (if (aref timer 7) " *" " ") + 'help-echo "* marks idle timers" + 'timer timer) + ;; Next time. + ,(propertize + (let ((time (list (aref timer 1) + (aref timer 2) + (aref timer 3)))) + (format "%10.2f" + (float-time + (if (aref timer 7) + time + (time-subtract time nil))))) + 'help-echo "Time in sec till next invocation") + ;; Repeat. + ,(propertize + (let ((repeat (aref timer 4))) + (cond + ((numberp repeat) + (format "%8.1f" repeat)) + ((null repeat) + " -") + (t + (format "%8s" repeat)))) + 'help-echo "Symbol: repeat; number: repeat interval in sec") + ;; Function. + ,(propertize + (let ((cl-print-compiled 'static) + (cl-print-compiled-button nil) + (print-escape-newlines t)) + (cl-prin1-to-string (aref timer 5))) + 'help-echo "Function called by timer")])) + (append timer-list timer-idle-list))) + (tabulated-list-print)) ;; This command can be destructive if they don't know what they are ;; doing. Kids, don't try this at home! ;;;###autoload (put 'list-timers 'disabled "Beware: manually canceling timers can ruin your Emacs session.") @@ -74,24 +82,47 @@ (defvar timer-list-mode-map (let ((map (make-sparse-keymap))) (define-key map "c" 'timer-list-cancel) - (define-key map "n" 'next-line) - (define-key map "p" 'previous-line) (easy-menu-define nil map "" '("Timers" ["Cancel" timer-list-cancel t])) map)) -(define-derived-mode timer-list-mode special-mode "Timer-List" +(define-derived-mode timer-list-mode tabulated-list-mode "Timer-List" "Mode for listing and controlling timers." - (setq bidi-paragraph-direction 'left-to-right) - (setq truncate-lines t) (buffer-disable-undo) (setq-local revert-buffer-function #'list-timers) - (setq buffer-read-only t) - (setq header-line-format - (concat (propertize " " 'display '(space :align-to 0)) - (format "%4s %10s %8s %s" - "Idle" "Next" "Repeat" "Function")))) + (setq tabulated-list-format + '[("Idle" 6 timer-list--idle-predicate) + (" Next" 12 timer-list--next-predicate) + (" Repeat" 11 timer-list--repeat-predicate) + ("Function" 10 timer-list--function-predicate)])) + +(defun timer-list--idle-predicate (A B) + "Predicate to sort Timer-List by the Idle column." + (let ((iA (aref (cadr A) 0)) + (iB (aref (cadr B) 0))) + (cond ((string= iA iB) + (timer-list--next-predicate A B)) + ((string= iA " *") nil) + (t t)))) + +(defun timer-list--next-predicate (A B) + "Predicate to sort Timer-List by the Next column." + (let ((nA (string-to-number (aref (cadr A) 1))) + (nB (string-to-number (aref (cadr B) 1)))) + (< nA nB))) + +(defun timer-list--repeat-predicate (A B) + "Predicate to sort Timer-List by the Repeat column." + (let ((rA (aref (cadr A) 2)) + (rB (aref (cadr B) 2))) + (string< rA rB))) + +(defun timer-list--function-predicate (A B) + "Predicate to sort Timer-List by the Next column." + (let ((fA (aref (cadr A) 3)) + (fB (aref (cadr B) 3))) + (string< fA fB))) (defun timer-list-cancel () "Cancel the timer on the line under point." diff --git a/lisp/emacs-lisp/timer.el b/lisp/emacs-lisp/timer.el index 9eb8feed0f1..61fd05cbb80 100644 --- a/lisp/emacs-lisp/timer.el +++ b/lisp/emacs-lisp/timer.el @@ -378,9 +378,6 @@ This function returns a timer object which you can use in (decoded-time-year now) (decoded-time-zone now))))))) - (or (time-equal-p time time) - (error "Invalid time format")) - (let ((timer (timer-create))) (timer-set-time timer time repeat) (timer-set-function timer function args) diff --git a/lisp/emulation/cua-base.el b/lisp/emulation/cua-base.el index 26a1a8955f4..c4dcb76446e 100644 --- a/lisp/emulation/cua-base.el +++ b/lisp/emulation/cua-base.el @@ -860,7 +860,7 @@ With numeric prefix arg, copy to register 0-9 instead." (defun cua-cancel () "Cancel the active region, rectangle, or global mark." (interactive) - (setq mark-active nil) + (deactivate-mark) (if (fboundp 'cua--cancel-rectangle) (cua--cancel-rectangle))) diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index 8dc18ebc85e..e70b44658d5 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -178,10 +178,8 @@ (defvar edt-user-global-map) (defvar rect-start-point) -;;; -;;; Version Information -;;; (defconst edt-version "4.0" "EDT Emulation version number.") +(make-obsolete-variable 'edt-version nil "28.1") ;;; ;;; User Configurable Variables diff --git a/lisp/emulation/viper-init.el b/lisp/emulation/viper-init.el index 511c68f24a7..6c4afe519f2 100644 --- a/lisp/emulation/viper-init.el +++ b/lisp/emulation/viper-init.el @@ -922,6 +922,8 @@ Should be set in `viper-custom-file-name'." "Hooks run just after loading Viper." :type 'hook :group 'viper-hooks) +(make-obsolete-variable 'viper-load-hook + "use `with-eval-after-load' instead." "28.1") (defun viper-restore-cursor-type () (condition-case nil diff --git a/lisp/emulation/viper-mous.el b/lisp/emulation/viper-mous.el index 294705f7c3a..6ecfec548cb 100644 --- a/lisp/emulation/viper-mous.el +++ b/lisp/emulation/viper-mous.el @@ -66,20 +66,13 @@ or a triple-click." ;; time interval in millisecond within which successive clicks are ;; considered related (defcustom viper-multiclick-timeout (if (viper-window-display-p) - (if (featurep 'xemacs) - mouse-track-multi-click-time - double-click-time) + double-click-time 500) "Time interval in millisecond within which successive mouse clicks are considered related." :type 'integer :group 'viper-mouse) -;; current event click count; XEmacs only -(defvar viper-current-click-count 0) -;; time stamp of the last click event; XEmacs only -(defvar viper-last-click-event-timestamp 0) - ;; Local variable used to toggle wraparound search on click. (viper-deflocalvar viper-mouse-click-search-noerror t) @@ -279,11 +272,9 @@ See `viper-surrounding-word' for the definition of a word in this case." (setq interrupting-event (read-event)) (viper-mouse-event-p last-input-event))) (progn ; interrupted wait - (setq viper-global-prefix-argument arg) - ;; count this click for XEmacs - (viper-event-click-count click)) + (setq viper-global-prefix-argument arg)) ;; uninterrupted wait or the interrupting event wasn't a mouse event - (setq click-count (viper-event-click-count click)) + (setq click-count (event-click-count click)) (if (> click-count 1) (setq arg viper-global-prefix-argument viper-global-prefix-argument nil)) @@ -300,33 +291,8 @@ See `viper-surrounding-word' for the definition of a word in this case." (string-match "\\(mouse-\\|frame\\|screen\\|track\\)" (prin1-to-string (viper-event-key event))))) -;; XEmacs has no double-click events. So, we must simulate. -;; So, we have to simulate event-click-count. -(defun viper-event-click-count (click) - (if (featurep 'xemacs) (viper-event-click-count-xemacs click) - (event-click-count click))) - -(when (featurep 'xemacs) - - ;; kind of semaphore for updating viper-current-click-count - (defvar viper-counting-clicks-p nil) - - (defun viper-event-click-count-xemacs (click) - (let ((time-delta (- (event-timestamp click) - viper-last-click-event-timestamp)) - inhibit-quit) - (while viper-counting-clicks-p - (ignore)) - (setq viper-counting-clicks-p t) - (if (> time-delta viper-multiclick-timeout) - (setq viper-current-click-count 0)) - (discard-input) - (setq viper-current-click-count (1+ viper-current-click-count) - viper-last-click-event-timestamp (event-timestamp click)) - (setq viper-counting-clicks-p nil) - (if (viper-sit-for-short viper-multiclick-timeout t) - viper-current-click-count - 0)))) +(define-obsolete-function-alias 'viper-event-click-count + 'event-click-count "28.1") (declare-function viper-forward-word "viper-cmd" (arg)) (declare-function viper-adjust-window "viper-cmd" ()) @@ -364,11 +330,9 @@ this command. (setq viper-global-prefix-argument (or viper-global-prefix-argument arg) ;; remember command that was before the multiclick - this-command last-command) - ;; make sure we counted this event---needed for XEmacs only - (viper-event-click-count click)) + this-command last-command)) ;; uninterrupted wait - (setq click-count (viper-event-click-count click)) + (setq click-count (event-click-count click)) (setq click-word (viper-mouse-click-get-word click nil click-count)) (if (> click-count 1) diff --git a/lisp/emulation/viper-util.el b/lisp/emulation/viper-util.el index ebad850e6b7..1561204151d 100644 --- a/lisp/emulation/viper-util.el +++ b/lisp/emulation/viper-util.el @@ -205,6 +205,7 @@ Otherwise return the normal value." ;; incorrect. However, this gives correct result in our cases, since we are ;; testing for sufficiently high Emacs versions. (defun viper-check-version (op major minor &optional type-of-emacs) + (declare (obsolete nil "28.1")) (if (and (boundp 'emacs-major-version) (boundp 'emacs-minor-version)) (and (cond ((eq type-of-emacs 'xemacs) (featurep 'xemacs)) ((eq type-of-emacs 'emacs) (featurep 'emacs)) diff --git a/lisp/emulation/viper.el b/lisp/emulation/viper.el index 492c31bde74..8e7a34fc69c 100644 --- a/lisp/emulation/viper.el +++ b/lisp/emulation/viper.el @@ -1221,7 +1221,6 @@ These two lines must come in the order given.")) (viper-harness-minor-mode "outline") (viper-harness-minor-mode "allout") (viper-harness-minor-mode "xref") - (viper-harness-minor-mode "lmenu") (viper-harness-minor-mode "vc") (viper-harness-minor-mode "ltx-math") ; LaTeX-math-mode in AUC-TeX, which (viper-harness-minor-mode "latex") ; sits in one of these two files diff --git a/lisp/epa-dired.el b/lisp/epa-dired.el index f601d426566..9269ea97070 100644 --- a/lisp/epa-dired.el +++ b/lisp/epa-dired.el @@ -29,48 +29,40 @@ (defun epa-dired-do-decrypt () "Decrypt marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-decrypt-file (expand-file-name (car file-list))) - (setq file-list (cdr file-list))) - (revert-buffer))) + (dolist (file (dired-get-marked-files)) + (epa-decrypt-file (expand-file-name file))) + (revert-buffer)) ;;;###autoload (defun epa-dired-do-verify () "Verify marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-verify-file (expand-file-name (car file-list))) - (setq file-list (cdr file-list))))) + (dolist (file (dired-get-marked-files)) + (epa-verify-file (expand-file-name file)))) ;;;###autoload (defun epa-dired-do-sign () "Sign marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-sign-file - (expand-file-name (car file-list)) - (epa-select-keys (epg-make-context) "Select keys for signing. + (dolist (file (dired-get-marked-files)) + (epa-sign-file + (expand-file-name file) + (epa-select-keys (epg-make-context) "Select keys for signing. If no one is selected, default secret key is used. " - nil t) - (y-or-n-p "Make a detached signature? ")) - (setq file-list (cdr file-list))) - (revert-buffer))) + nil t) + (y-or-n-p "Make a detached signature? "))) + (revert-buffer)) ;;;###autoload (defun epa-dired-do-encrypt () "Encrypt marked files." (interactive) - (let ((file-list (dired-get-marked-files))) - (while file-list - (epa-encrypt-file - (expand-file-name (car file-list)) - (epa-select-keys (epg-make-context) "Select recipients for encryption. -If no one is selected, symmetric encryption will be performed. ")) - (setq file-list (cdr file-list))) - (revert-buffer))) + (dolist (file (dired-get-marked-files)) + (epa-encrypt-file + (expand-file-name file) + (epa-select-keys (epg-make-context) "Select recipients for encryption. +If no one is selected, symmetric encryption will be performed. "))) + (revert-buffer)) (provide 'epa-dired) diff --git a/lisp/epa-file.el b/lisp/epa-file.el index dedf20b0d77..20043a9eae4 100644 --- a/lisp/epa-file.el +++ b/lisp/epa-file.el @@ -40,9 +40,9 @@ Note that this option has no effect if you use GnuPG 2.0." (defcustom epa-file-select-keys nil "Control whether or not to pop up the key selection dialog. -If t, always asks user to select recipients. +If t, always ask user to select recipients. If nil, query user only when `epa-file-encrypt-to' is not set. -If neither t nor nil, doesn't ask user. In this case, symmetric +If neither t nor nil, don't ask user. In this case, symmetric encryption is used." :type '(choice (const :tag "Ask always" t) (const :tag "Ask when recipients are not set" nil) @@ -51,16 +51,6 @@ encryption is used." (defvar epa-file-passphrase-alist nil) -(eval-and-compile - (if (fboundp 'encode-coding-string) - (defalias 'epa-file--encode-coding-string 'encode-coding-string) - (defalias 'epa-file--encode-coding-string 'identity))) - -(eval-and-compile - (if (fboundp 'decode-coding-string) - (defalias 'epa-file--decode-coding-string 'decode-coding-string) - (defalias 'epa-file--decode-coding-string 'identity))) - (defun epa-file-passphrase-callback-function (context key-id file) (if (and epa-file-cache-passphrase-for-symmetric-encryption (eq key-id 'SYM)) @@ -71,8 +61,8 @@ encryption is used." (or (copy-sequence (cdr entry)) (progn (unless entry - (setq entry (list file) - epa-file-passphrase-alist + (setq entry (list file)) + (setq epa-file-passphrase-alist (cons entry epa-file-passphrase-alist))) (setq passphrase (epa-passphrase-callback-function context @@ -236,11 +226,7 @@ encryption is used." (setq file (expand-file-name file)) (let* ((coding-system (or coding-system-for-write (if (fboundp 'select-safe-coding-system) - ;; This is needed since Emacs 22 has - ;; no-conversion setting for *.gpg in - ;; `auto-coding-alist'. - (let ((buffer-file-name - (file-name-sans-extension file))) + (let ((buffer-file-name file)) (select-safe-coding-system (point-min) (point-max))) buffer-file-coding-system))) @@ -266,7 +252,7 @@ encryption is used." (epg-encrypt-string context (if (stringp start) - (epa-file--encode-coding-string start coding-system) + (encode-coding-string start coding-system) (unless start (setq start (point-min) end (point-max))) @@ -280,8 +266,8 @@ encryption is used." ;; decrypted contents. (format-encode-buffer (with-current-buffer buffer buffer-file-format)) - (epa-file--encode-coding-string (buffer-string) - coding-system))) + (encode-coding-string (buffer-string) + coding-system))) (if (or (eq epa-file-select-keys t) (and (null epa-file-select-keys) (not (local-variable-p 'epa-file-encrypt-to diff --git a/lisp/epa-hook.el b/lisp/epa-hook.el index d424e7a9faf..a86f23eb688 100644 --- a/lisp/epa-hook.el +++ b/lisp/epa-hook.el @@ -35,10 +35,10 @@ (defcustom epa-file-name-regexp (purecopy "\\.gpg\\(~\\|\\.~[0-9]+~\\)?\\'") "Regexp which matches filenames to be encrypted with GnuPG. -If you set this outside Custom while epa-file is already enabled, you -have to call `epa-file-name-regexp-update' after setting it to -properly update file-name-handler-alist. Setting this through Custom -does that automatically." +If you set this outside Custom while epa-file is already enabled, +you have to call `epa-file-name-regexp-update' after setting it +to properly update `file-name-handler-alist'. Setting this +through Custom does that automatically." :type 'regexp :group 'epa-file :set 'epa-file--file-name-regexp-set) @@ -72,6 +72,9 @@ May either be a string or a list of strings.") (list epa-file-name-regexp nil 'epa-file)) (defun epa-file-name-regexp-update () + "Update `file-name-handler-alist' after configuring outside Custom. +After setting `epa-file-name-regexp-update' outside the Custom +interface, update `file-name-handler-alist'." (interactive) (unless (equal (car epa-file-handler) epa-file-name-regexp) (setcar epa-file-handler epa-file-name-regexp))) diff --git a/lisp/epa.el b/lisp/epa.el index 47c177e6cd5..3c7dd8309a8 100644 --- a/lisp/epa.el +++ b/lisp/epa.el @@ -25,7 +25,9 @@ (require 'epg) (require 'font-lock) (require 'widget) -(eval-when-compile (require 'wid-edit)) +(eval-when-compile + (require 'subr-x) + (require 'wid-edit)) (require 'derived) (defgroup epa nil @@ -56,11 +58,6 @@ If neither t nor nil, ask user for confirmation." :type 'integer :group 'epa) -(defgroup epa-faces nil - "Faces for epa-mode." - :version "23.1" - :group 'epa) - (defcustom epa-mail-aliases nil "Alist of aliases of email addresses that stand for encryption keys. Each element is a list of email addresses (ALIAS EXPANSIONS...). @@ -76,6 +73,11 @@ The command `epa-mail-encrypt' uses this." :group 'epa :version "24.4") +(defgroup epa-faces nil + "Faces for epa-mode." + :version "23.1" + :group 'epa) + (defface epa-validity-high '((default :weight bold) (((class color) (background dark)) :foreground "PaleTurquoise")) @@ -117,13 +119,15 @@ The command `epa-mail-encrypt' uses this." '((default :weight bold) (((class color) (background dark)) :foreground "PaleTurquoise")) "Face for the name of the attribute field." - :group 'epa) + :version "28.1" + :group 'epa-faces) (defface epa-field-body '((default :slant italic) (((class color) (background dark)) :foreground "turquoise")) "Face for the body of the attribute field." - :group 'epa) + :version "28.1" + :group 'epa-faces) (defcustom epa-validity-face-alist '((unknown . epa-validity-disabled) @@ -138,8 +142,9 @@ The command `epa-mail-encrypt' uses this." (full . epa-validity-high) (ultimate . epa-validity-high)) "An alist mapping validity values to faces." + :version "28.1" :type '(repeat (cons symbol face)) - :group 'epa) + :group 'epa-faces) (defvar epa-font-lock-keywords '(("^\\*" @@ -185,6 +190,8 @@ You should bind this variable with `let', but do not set it globally.") (defvar epa-key-list-mode-map (let ((keymap (make-sparse-keymap)) (menu-map (make-sparse-keymap))) + (set-keymap-parent keymap widget-keymap) + (define-key keymap "\C-m" 'epa-show-key) (define-key keymap "m" 'epa-mark-key) (define-key keymap "u" 'epa-unmark-key) (define-key keymap "d" 'epa-decrypt-file) @@ -332,8 +339,7 @@ If ARG is non-nil, mark the key." (epa-mark-key (not arg))) (defun epa-exit-buffer () - "Exit the current buffer. -`epa-exit-buffer-function' is called if it is set." + "Exit the current buffer using `epa-exit-buffer-function'." (interactive) (funcall epa-exit-buffer-function)) @@ -361,7 +367,10 @@ If ARG is non-nil, mark the key." 'start-open t 'end-open t))))) -(defun epa--list-keys (name secret) +(defun epa--list-keys (name secret &optional doc) + "NAME specifies which key to list. +SECRET says list data on the secret key (default, the public key). +DOC is documentation text to insert at the start." (unless (and epa-keys-buffer (buffer-live-p epa-keys-buffer)) (setq epa-keys-buffer (generate-new-buffer "*Keys*"))) @@ -371,16 +380,30 @@ If ARG is non-nil, mark the key." buffer-read-only (point (point-min)) (context (epg-make-context epa-protocol))) + + ;; Find the end of the documentation text at the start. + ;; Set POINT to where it ends, or nil if ends at eob. (unless (get-text-property point 'epa-list-keys) (setq point (next-single-property-change point 'epa-list-keys))) + + ;; If caller specified documentation text for that, replace the old + ;; documentation text (if any) with what was specified. + ;; Otherwise, preserve whatever intro text is present. + (when doc + (if (or point (not (eobp))) + (delete-region (point-min) point)) + (insert doc) + (setq point (point))) + + ;; Now delete the key description text, if any. (when point (delete-region point (or (next-single-property-change point 'epa-list-keys) (point-max))) (goto-char point)) + (epa--insert-keys (epg-list-keys context name secret)) - (widget-setup) - (set-keymap-parent (current-local-map) widget-keymap)) + (widget-setup)) (make-local-variable 'epa-list-keys-arguments) (setq epa-list-keys-arguments (list name secret)) (goto-char (point-min)) @@ -396,7 +419,13 @@ If ARG is non-nil, mark the key." (car epa-list-keys-arguments))))) (list (if (equal name "") nil name))) (list nil))) - (epa--list-keys name nil)) + (epa--list-keys name nil + "The letters at the start of a line have these meanings. +e expired key. n never trust. m trust marginally. u trust ultimately. +f trust fully (keys you have signed, usually). +q trust status questionable. - trust status unspecified. + See GPG documentaion for more explanation. +\n")) ;;;###autoload (defun epa-list-secret-keys (&optional name) @@ -476,6 +505,14 @@ If SECRET is non-nil, list secret keys instead of public keys." (let ((keys (epg-list-keys context names secret))) (epa--select-keys prompt keys))) +(defun epa-show-key () + "Show a key on the current line." + (interactive) + (if-let ((key (get-text-property (point) 'epa-key))) + (save-selected-window + (epa--show-key key)) + (error "No key on this line"))) + (defun epa--show-key (key) (let* ((primary-sub-key (car (epg-key-sub-key-list key))) (entry (assoc (epg-sub-key-id primary-sub-key) diff --git a/lisp/epg-config.el b/lisp/epg-config.el index daa9a5abd17..1c429246529 100644 --- a/lisp/epg-config.el +++ b/lisp/epg-config.el @@ -202,13 +202,13 @@ version requirement is met." (cond ((eq type 'group) (if (string-match "\\`\\([^:]+\\):" args) - (setq groups - (cons (cons (downcase (match-string 1 args)) - (delete "" (split-string - (substring args - (match-end 0)) - ";"))) - groups)) + (setq groups + (cons (cons (downcase (match-string 1 args)) + (delete "" (split-string + (substring args + (match-end 0)) + ";"))) + groups)) (if epg-debug (message "Invalid group configuration: %S" args)))) ((memq type '(pubkey cipher digest compress)) diff --git a/lisp/erc/erc-backend.el b/lisp/erc/erc-backend.el index 526e854beca..1e2526f35ce 100644 --- a/lisp/erc/erc-backend.el +++ b/lisp/erc/erc-backend.el @@ -375,7 +375,7 @@ Example: If you know that the channel #linux-ru uses the coding-system `cyrillic-koi8', then add (\"#linux-ru\" . cyrillic-koi8) to the alist." :group 'erc-server - :type '(repeat (cons (string :tag "Target") + :type '(repeat (cons (regexp :tag "Target") coding-system))) (defcustom erc-server-connect-function #'erc-open-network-stream diff --git a/lisp/erc/erc-dcc.el b/lisp/erc/erc-dcc.el index 26701cec1e4..8ccceec4594 100644 --- a/lisp/erc/erc-dcc.el +++ b/lisp/erc/erc-dcc.el @@ -627,11 +627,11 @@ that subcommand." ?q query ?n nick ?u login ?h host)))) (defconst erc-dcc-ctcp-query-send-regexp - (concat "^DCC SEND \\(" + (concat "^DCC SEND \\(?:" ;; Following part matches either filename without spaces ;; or filename enclosed in double quotes with any number ;; of escaped double quotes inside. - "\"\\(\\(.*?\\(\\\\\"\\)?\\)+?\\)\"\\|\\([^ ]+\\)" + "\"\\(\\(?:\\\\\"\\|[^\"\\]\\)+\\)\"\\|\\([^ ]+\\)" "\\) \\([0-9]+\\) \\([0-9]+\\) *\\([0-9]*\\)")) (define-inline erc-dcc-unquote-filename (filename) @@ -653,11 +653,11 @@ It extracts the information about the dcc request and adds it to ?r "SEND" ?n nick ?u login ?h host)) ((string-match erc-dcc-ctcp-query-send-regexp query) (let ((filename - (or (match-string 5 query) - (erc-dcc-unquote-filename (match-string 2 query)))) - (ip (erc-decimal-to-ip (match-string 6 query))) - (port (match-string 7 query)) - (size (match-string 8 query))) + (or (match-string 2 query) + (erc-dcc-unquote-filename (match-string 1 query)))) + (ip (erc-decimal-to-ip (match-string 3 query))) + (port (match-string 4 query)) + (size (match-string 5 query))) ;; FIXME: a warning really should also be sent ;; if the ip address != the host the dcc sender is on. (erc-display-message diff --git a/lisp/erc/erc-ezbounce.el b/lisp/erc/erc-ezbounce.el index 1032af7a304..5c2faff96de 100644 --- a/lisp/erc/erc-ezbounce.el +++ b/lisp/erc/erc-ezbounce.el @@ -34,7 +34,7 @@ (defcustom erc-ezb-regexp "^ezbounce!srv$" "Regexp used by the EZBouncer to identify itself to the user." :group 'erc-ezbounce - :type 'string) + :type 'regexp) (defcustom erc-ezb-login-alist '() "Alist of logins suitable for the server we're connecting to. diff --git a/lisp/erc/erc-match.el b/lisp/erc/erc-match.el index 3107ff2ccd1..0e98f2bc613 100644 --- a/lisp/erc/erc-match.el +++ b/lisp/erc/erc-match.el @@ -555,16 +555,15 @@ See `erc-log-match-format'." (and (eq erc-log-matches-flag 'away) (erc-away-time))) match-buffer-name) - (let ((line (format-spec erc-log-match-format - (format-spec-make - ?n nick - ?t (format-time-string - (or (and (boundp 'erc-timestamp-format) - erc-timestamp-format) - "[%Y-%m-%d %H:%M] ")) - ?c (or (erc-default-target) "") - ?m message - ?u nickuserhost)))) + (let ((line (format-spec + erc-log-match-format + `((?n . ,nick) + (?t . ,(format-time-string + (or (bound-and-true-p erc-timestamp-format) + "[%Y-%m-%d %H:%M] "))) + (?c . ,(or (erc-default-target) "")) + (?m . ,message) + (?u . ,nickuserhost))))) (with-current-buffer (erc-log-matches-make-buffer match-buffer-name) (let ((inhibit-read-only t)) (goto-char (point-max)) diff --git a/lisp/erc/erc-speedbar.el b/lisp/erc/erc-speedbar.el index 5a469aa4e4e..b64e42b7ee4 100644 --- a/lisp/erc/erc-speedbar.el +++ b/lisp/erc/erc-speedbar.el @@ -90,9 +90,8 @@ nil - Do not sort users" "Additional menu-items to add to speedbar frame.") ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (erc-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'erc-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (erc-install-speedbar-variables)) ;;; ERC hierarchy display method ;;;###autoload diff --git a/lisp/erc/erc.el b/lisp/erc/erc.el index cfde84e19aa..bfe8a2b42eb 100644 --- a/lisp/erc/erc.el +++ b/lisp/erc/erc.el @@ -1212,7 +1212,7 @@ which the local user typed." :group 'erc-faces) (defface erc-header-line - '((t :foreground "grey20" :background "grey90")) + '((t :inherit header-line)) "ERC face used for the header line. This will only be used if `erc-header-line-face-method' is non-nil." @@ -6391,17 +6391,16 @@ if `erc-away' is non-nil." (defun erc-update-mode-line-buffer (buffer) "Update the mode line in a single ERC buffer BUFFER." (with-current-buffer buffer - (let ((spec (format-spec-make - ?a (erc-format-away-status) - ?l (erc-format-lag-time) - ?m (erc-format-channel-modes) - ?n (or (erc-current-nick) "") - ?N (erc-format-network) - ?o (or (erc-controls-strip erc-channel-topic) "") - ?p (erc-port-to-string erc-session-port) - ?s (erc-format-target-and/or-server) - ?S (erc-format-target-and/or-network) - ?t (erc-format-target))) + (let ((spec `((?a . ,(erc-format-away-status)) + (?l . ,(erc-format-lag-time)) + (?m . ,(erc-format-channel-modes)) + (?n . ,(or (erc-current-nick) "")) + (?N . ,(erc-format-network)) + (?o . ,(or (erc-controls-strip erc-channel-topic) "")) + (?p . ,(erc-port-to-string erc-session-port)) + (?s . ,(erc-format-target-and/or-server)) + (?S . ,(erc-format-target-and/or-network)) + (?t . ,(erc-format-target)))) (process-status (cond ((and (erc-server-process-alive) (not erc-server-connected)) ":connecting") diff --git a/lisp/eshell/em-cmpl.el b/lisp/eshell/em-cmpl.el index 48c99acac33..dcf56af6051 100644 --- a/lisp/eshell/em-cmpl.el +++ b/lisp/eshell/em-cmpl.el @@ -244,6 +244,26 @@ to writing a completion function." (let ((completion-at-point-functions '(elisp-completion-at-point))) (completion-at-point))) +(defvar eshell-cmpl-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?i)] #'completion-at-point) + ;; jww (1999-10-19): Will this work on anything but X? + (define-key map [backtab] #'pcomplete-reverse) + (define-key map [(meta ??)] #'completion-help-at-point) + (define-key map [(meta control ?i)] #'eshell-complete-lisp-symbol) + ;; C-c prefix: + (define-key map (kbd "C-c M-h") #'eshell-completion-help) + (define-key map (kbd "C-c TAB") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c C-i") #'pcomplete-expand-and-complete) + (define-key map (kbd "C-c SPC") #'pcomplete-expand) + map)) + +(define-minor-mode eshell-cmpl-mode + "Minor mode that provides a keymap when `eshell-cmpl' active. + +\\{eshell-cmpl-mode-map}" + :keymap eshell-cmpl-mode-map) + (defun eshell-cmpl-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the completions module." (set (make-local-variable 'pcomplete-command-completion-function) @@ -291,22 +311,9 @@ to writing a completion function." eshell-special-chars-outside-quoting))) nil t) (add-hook 'pcomplete-quote-arg-hook #'eshell-quote-backslash nil t) - ;;(define-key eshell-mode-map [(meta tab)] 'eshell-complete-lisp-symbol) ; Redundant - (define-key eshell-mode-map [(meta control ?i)] 'eshell-complete-lisp-symbol) - (define-key eshell-command-map [(meta ?h)] 'eshell-completion-help) - (define-key eshell-command-map [tab] 'pcomplete-expand-and-complete) - (define-key eshell-command-map [(control ?i)] - 'pcomplete-expand-and-complete) - (define-key eshell-command-map [space] 'pcomplete-expand) - (define-key eshell-command-map [? ] 'pcomplete-expand) - ;;(define-key eshell-mode-map [tab] 'completion-at-point) ;Redundant! - (define-key eshell-mode-map [(control ?i)] 'completion-at-point) (add-hook 'completion-at-point-functions #'pcomplete-completions-at-point nil t) - ;; jww (1999-10-19): Will this work on anything but X? - (define-key eshell-mode-map - (if (featurep 'xemacs) [iso-left-tab] [backtab]) 'pcomplete-reverse) - (define-key eshell-mode-map [(meta ??)] 'completion-help-at-point)) + (eshell-cmpl-mode)) (defun eshell-completion-command-name () "Return the command name, possibly sans globbing." diff --git a/lisp/eshell/em-dirs.el b/lisp/eshell/em-dirs.el index 1949e5dc8fc..51df6fa1d52 100644 --- a/lisp/eshell/em-dirs.el +++ b/lisp/eshell/em-dirs.el @@ -168,6 +168,9 @@ Thus, this does not include the current directory.") (defvar eshell-last-dir-ring nil "The last directory that Eshell was in.") +(defconst eshell-inside-emacs (format "%s,eshell" emacs-version) + "Value for the `INSIDE_EMACS' environment variable.") + ;;; Functions: (defun eshell-dirs-initialize () ;Called from `eshell-mode' via intern-soft! @@ -191,6 +194,8 @@ Thus, this does not include the current directory.") (unless (ring-empty-p eshell-last-dir-ring) (expand-file-name (ring-ref eshell-last-dir-ring 0)))) + t) + ("INSIDE_EMACS" eshell-inside-emacs t)))) (when eshell-cd-on-directory diff --git a/lisp/eshell/em-glob.el b/lisp/eshell/em-glob.el index 43483dcd50e..a32a6abe29c 100644 --- a/lisp/eshell/em-glob.el +++ b/lisp/eshell/em-glob.el @@ -232,8 +232,6 @@ resulting regular expression." (regexp-quote (substring pattern matched-in-pattern)) "\\'"))) -(defvar ange-cache) ; XEmacs? See esh-util - (defun eshell-extended-glob (glob) "Return a list of files generated from GLOB, perhaps looking for DIRS-ONLY. This function almost fully supports zsh style filename generation @@ -252,7 +250,7 @@ the form: (INCLUDE-REGEXP EXCLUDE-REGEXP (PRED-FUNC-LIST) (MOD-FUNC-LIST))" (let ((paths (eshell-split-path glob)) - eshell-glob-matches message-shown ange-cache) + eshell-glob-matches message-shown) (unwind-protect (if (and (cdr paths) (file-name-absolute-p (car paths))) diff --git a/lisp/eshell/em-hist.el b/lisp/eshell/em-hist.el index 73742a361da..267936583e1 100644 --- a/lisp/eshell/em-hist.el +++ b/lisp/eshell/em-hist.el @@ -202,6 +202,32 @@ element, regardless of any text on the command line. In that case, map) "Keymap used in isearch in Eshell.") +(defvar eshell-hist-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [up] #'eshell-previous-matching-input-from-input) + (define-key map [down] #'eshell-next-matching-input-from-input) + (define-key map [(control up)] #'eshell-previous-input) + (define-key map [(control down)] #'eshell-next-input) + (define-key map [(meta ?r)] #'eshell-previous-matching-input) + (define-key map [(meta ?s)] #'eshell-next-matching-input) + (define-key map (kbd "C-c M-r") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-s") #'eshell-next-matching-input-from-input) + ;; FIXME: Relies on `eshell-hist-match-partial' being set _before_ + ;; em-hist is loaded and won't respect changes. + (if eshell-hist-match-partial + (progn + (define-key map [(meta ?p)] 'eshell-previous-matching-input-from-input) + (define-key map [(meta ?n)] 'eshell-next-matching-input-from-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-input) + (define-key map (kbd "C-c M-n") #'eshell-next-input)) + (define-key map [(meta ?p)] #'eshell-previous-input) + (define-key map [(meta ?n)] #'eshell-next-input) + (define-key map (kbd "C-c M-p") #'eshell-previous-matching-input-from-input) + (define-key map (kbd "C-c M-n") #'eshell-next-matching-input-from-input)) + (define-key map (kbd "C-c C-l") #'eshell-list-history) + (define-key map (kbd "C-c C-x") #'eshell-get-next-from-history) + map)) + (defvar eshell-rebind-keys-alist) ;;; Functions: @@ -216,6 +242,12 @@ Returns non-nil if INPUT is blank." Returns nil if INPUT is prepended by blank space, otherwise non-nil." (not (string-match-p "\\`\\s-+" input))) +(define-minor-mode eshell-hist-mode + "Minor mode for the eshell-hist module. + +\\{eshell-hist-mode-map}" + :keymap eshell-hist-mode-map) + (defun eshell-hist-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the history management code for one Eshell buffer." (when (eshell-using-module 'eshell-cmpl) @@ -242,30 +274,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (lambda () (setq overriding-terminal-local-map nil))) nil t)) - (define-key eshell-mode-map [up] 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [down] 'eshell-next-matching-input-from-input) - (define-key eshell-mode-map [(control up)] 'eshell-previous-input) - (define-key eshell-mode-map [(control down)] 'eshell-next-input) - (define-key eshell-mode-map [(meta ?r)] 'eshell-previous-matching-input) - (define-key eshell-mode-map [(meta ?s)] 'eshell-next-matching-input) - (define-key eshell-command-map [(meta ?r)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?s)] - 'eshell-next-matching-input-from-input) - (if eshell-hist-match-partial - (progn - (define-key eshell-mode-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-mode-map [(meta ?n)] - 'eshell-next-matching-input-from-input) - (define-key eshell-command-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-command-map [(meta ?n)] 'eshell-next-input)) - (define-key eshell-mode-map [(meta ?p)] 'eshell-previous-input) - (define-key eshell-mode-map [(meta ?n)] 'eshell-next-input) - (define-key eshell-command-map [(meta ?p)] - 'eshell-previous-matching-input-from-input) - (define-key eshell-command-map [(meta ?n)] - 'eshell-next-matching-input-from-input))) + (eshell-hist-mode)) (make-local-variable 'eshell-history-size) (or eshell-history-size @@ -300,10 +309,7 @@ Returns nil if INPUT is prepended by blank space, otherwise non-nil." (add-hook 'kill-emacs-hook #'eshell-save-some-history) (make-local-variable 'eshell-input-filter-functions) - (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t) - - (define-key eshell-command-map [(control ?l)] 'eshell-list-history) - (define-key eshell-command-map [(control ?x)] 'eshell-get-next-from-history)) + (add-hook 'eshell-input-filter-functions #'eshell-add-to-history nil t)) (defun eshell-save-some-history () "Save the history for any open Eshell buffers." diff --git a/lisp/eshell/em-ls.el b/lisp/eshell/em-ls.el index 70b3ad611a1..c1a022ee521 100644 --- a/lisp/eshell/em-ls.el +++ b/lisp/eshell/em-ls.el @@ -239,7 +239,6 @@ scope during the evaluation of TEST-SEXP." (defvar show-recursive) (defvar show-size) (defvar sort-method) -(defvar ange-cache) (defvar dired-flag) ;;; Functions: @@ -406,7 +405,7 @@ Sort entries alphabetically across.") (setq listing-style 'by-columns)) (unless args (setq args (list "."))) - (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp) ange-cache) + (let ((eshell-ls-exclude-regexp eshell-ls-exclude-regexp)) (when ignore-pattern (unless (eshell-using-module 'eshell-glob) (error (concat "-I option requires that `eshell-glob'" diff --git a/lisp/eshell/em-pred.el b/lisp/eshell/em-pred.el index ee4b28fb3ae..c26f654e278 100644 --- a/lisp/eshell/em-pred.el +++ b/lisp/eshell/em-pred.el @@ -229,6 +229,12 @@ FOR LISTS OF ARGUMENTS: EXAMPLES: *.c(:o) sorted list of .c files") +(defvar eshell-pred-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-q") #'eshell-display-predicate-help) + (define-key map (kbd "C-c M-m") #'eshell-display-modifier-help) + map)) + ;;; Functions: (defun eshell-display-predicate-help () @@ -245,12 +251,17 @@ EXAMPLES: (lambda () (insert eshell-modifier-help-string))))) +(define-minor-mode eshell-pred-mode + "Minor mode for the eshell-pred module. + +\\{eshell-pred-mode-map}" + :keymap eshell-pred-mode-map) + (defun eshell-pred-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the predicate/modifier code." (add-hook 'eshell-parse-argument-hook #'eshell-parse-arg-modifier t t) - (define-key eshell-command-map [(meta ?q)] 'eshell-display-predicate-help) - (define-key eshell-command-map [(meta ?m)] 'eshell-display-modifier-help)) + (eshell-pred-mode)) (defun eshell-apply-modifiers (lst predicates modifiers) "Apply to LIST a series of PREDICATES and MODIFIERS." @@ -440,11 +451,9 @@ resultant list of strings." `(lambda (file) (let ((attrs (file-attributes file))) (if attrs - (,(if (eq qual ?-) - 'time-less-p - (if (eq qual ?+) - '(lambda (a b) (time-less-p b a)) - 'time-equal-p)) + (,(cond ((eq qual ?-) #'time-less-p) + ((eq qual ?+) (lambda (a b) (time-less-p b a))) + (#'time-equal-p)) ,when (nth ,attr-index attrs))))))) (defun eshell-pred-file-type (type) @@ -467,7 +476,7 @@ that `ls -l' will show in the first column of its display." (defsubst eshell-pred-file-mode (mode) "Return a test which tests that MODE pertains to the file." `(lambda (file) - (let ((modes (file-modes file))) + (let ((modes (file-modes file 'nofollow))) (if modes (logand ,mode modes))))) diff --git a/lisp/eshell/em-prompt.el b/lisp/eshell/em-prompt.el index bbf3b94ff44..9ae5ae12816 100644 --- a/lisp/eshell/em-prompt.el +++ b/lisp/eshell/em-prompt.el @@ -97,8 +97,20 @@ arriving, or after." :options '(eshell-show-maximum-output) :group 'eshell-prompt) +(defvar eshell-prompt-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c C-n") #'eshell-next-prompt) + (define-key map (kbd "C-c C-p") #'eshell-previous-prompt) + map)) + ;;; Functions: +(define-minor-mode eshell-prompt-mode + "Minor mode for eshell-prompt module. + +\\{eshell-prompt-mode-map}" + :keymap eshell-prompt-mode-map) + (defun eshell-prompt-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the prompting code." (unless eshell-non-interactive-p @@ -110,9 +122,7 @@ arriving, or after." (set (make-local-variable 'eshell-skip-prompt-function) 'eshell-skip-prompt) - - (define-key eshell-command-map [(control ?n)] 'eshell-next-prompt) - (define-key eshell-command-map [(control ?p)] 'eshell-previous-prompt))) + (eshell-prompt-mode))) (defun eshell-emit-prompt () "Emit a prompt if eshell is being used interactively." diff --git a/lisp/eshell/em-rebind.el b/lisp/eshell/em-rebind.el index 85593e45160..bf5a4bf1afe 100644 --- a/lisp/eshell/em-rebind.el +++ b/lisp/eshell/em-rebind.el @@ -137,6 +137,11 @@ This is default behavior of shells like bash." :type '(repeat function) :group 'eshell-rebind) +(defvar eshell-rebind-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-l") #'eshell-lock-local-map) + map)) + ;; Internal Variables: (defvar eshell-input-keymap) @@ -145,6 +150,12 @@ This is default behavior of shells like bash." ;;; Functions: +(define-minor-mode eshell-rebind-mode + "Minor mode for the eshell-rebind module. + +\\{eshell-rebind-mode-map}" + :keymap eshell-rebind-mode-map) + (defun eshell-rebind-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the inputting code." (unless eshell-non-interactive-p @@ -154,7 +165,7 @@ This is default behavior of shells like bash." (make-local-variable 'overriding-local-map) (add-hook 'post-command-hook 'eshell-rebind-input-map nil t) (set (make-local-variable 'eshell-lock-keymap) nil) - (define-key eshell-command-map [(meta ?l)] 'eshell-lock-local-map))) + (eshell-rebind-mode))) (defun eshell-lock-local-map (&optional arg) "Lock or unlock the current local keymap. diff --git a/lisp/eshell/em-unix.el b/lisp/eshell/em-unix.el index 51699a7aa46..fbd3cfbb6fc 100644 --- a/lisp/eshell/em-unix.el +++ b/lisp/eshell/em-unix.el @@ -469,8 +469,6 @@ Remove the DIRECTORY(ies), if they are empty.") (eshell-parse-command (format "tar %s %s" tar-args archive) args)))) -(defvar ange-cache) ; XEmacs? See esh-util - ;; this is to avoid duplicating code... (defmacro eshell-mvcpln-template (command action func query-var force-var &optional preserve) @@ -488,8 +486,7 @@ Remove the DIRECTORY(ies), if they are empty.") (or (not no-dereference) (not (file-symlink-p (car args))))))) (eshell-shorthand-tar-command ,command args) - (let ((target (car (last args))) - ange-cache) + (let ((target (car (last args)))) (setcdr (last args 2) nil) (eshell-shuffle-files ,command ,action args target ,func nil @@ -924,7 +921,7 @@ Summarize disk usage of each FILE, recursively for directories.") ;; filesystem support means nothing under Windows (if (eshell-under-windows-p) (setq only-one-filesystem nil)) - (let ((size 0.0) ange-cache) + (let ((size 0.0)) (while args (if only-one-filesystem (setq only-one-filesystem diff --git a/lisp/eshell/esh-arg.el b/lisp/eshell/esh-arg.el index 86ceb41ffd2..e7b07b4208d 100644 --- a/lisp/eshell/esh-arg.el +++ b/lisp/eshell/esh-arg.el @@ -155,14 +155,22 @@ treated as a literal character." :type 'hook :group 'eshell-arg) +(defvar eshell-arg-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-b") #'eshell-insert-buffer-name) + map)) + ;;; Functions: +(define-minor-mode eshell-arg-mode + "Minor mode for the arg eshell module. + +\\{eshell-arg-mode-map}" + :keymap eshell-arg-mode-map) + (defun eshell-arg-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the argument parsing code." - ;; This is supposedly run after enabling esh-mode, when eshell-mode-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?b)] 'eshell-insert-buffer-name) + (eshell-arg-mode) (set (make-local-variable 'eshell-inside-quote-regexp) nil) (set (make-local-variable 'eshell-outside-quote-regexp) nil)) diff --git a/lisp/eshell/esh-mode.el b/lisp/eshell/esh-mode.el index db5fddb2aaf..d0147b345aa 100644 --- a/lisp/eshell/esh-mode.el +++ b/lisp/eshell/esh-mode.el @@ -213,10 +213,7 @@ This is used by `eshell-watch-for-password-prompt'." ;; these are only set to nil initially for the sake of the ;; byte-compiler, when compiling other files which `require' this one (defvar eshell-mode nil) -(defvar eshell-mode-map nil) (defvar eshell-command-running-string "--") -(defvar eshell-command-map nil) -(defvar eshell-command-prefix nil) (defvar eshell-last-input-start nil) (defvar eshell-last-input-end nil) (defvar eshell-last-output-start nil) @@ -280,6 +277,32 @@ This is used by `eshell-watch-for-password-prompt'." (standard-syntax-table)) st)) +(defvar eshell-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [(control ?c)] 'eshell-command-map) + (define-key map "\r" #'eshell-send-input) + (define-key map "\M-\r" #'eshell-queue-input) + (define-key map [(meta control ?l)] #'eshell-show-output) + (define-key map [(control ?a)] #'eshell-bol) + map)) + +(defvar eshell-command-map + (let ((map (define-prefix-command 'eshell-command-map))) + (define-key map [(meta ?o)] #'eshell-mark-output) + (define-key map [(meta ?d)] #'eshell-toggle-direct-send) + (define-key map [(control ?a)] #'eshell-bol) + (define-key map [(control ?b)] #'eshell-backward-argument) + (define-key map [(control ?e)] #'eshell-show-maximum-output) + (define-key map [(control ?f)] #'eshell-forward-argument) + (define-key map [(control ?m)] #'eshell-copy-old-input) + (define-key map [(control ?o)] #'eshell-kill-output) + (define-key map [(control ?r)] #'eshell-show-output) + (define-key map [(control ?t)] #'eshell-truncate-buffer) + (define-key map [(control ?u)] #'eshell-kill-input) + (define-key map [(control ?w)] #'backward-kill-word) + (define-key map [(control ?y)] #'eshell-repeat-argument) + map)) + ;;; User Functions: (defun eshell-kill-buffer-function () @@ -298,10 +321,6 @@ and the hook `eshell-exit-hook'." "Emacs shell interactive mode." (setq-local eshell-mode t) - ;; FIXME: What the hell!? - (setq-local eshell-mode-map (make-sparse-keymap)) - (use-local-map eshell-mode-map) - (when eshell-status-in-mode-line (make-local-variable 'eshell-command-running-string) (let ((fmt (copy-sequence mode-line-format))) @@ -310,31 +329,6 @@ and the hook `eshell-exit-hook'." (if mode-line-elt (setcar mode-line-elt 'eshell-command-running-string)))) - (define-key eshell-mode-map "\r" 'eshell-send-input) - (define-key eshell-mode-map "\M-\r" 'eshell-queue-input) - (define-key eshell-mode-map [(meta control ?l)] 'eshell-show-output) - (define-key eshell-mode-map [(control ?a)] 'eshell-bol) - - (setq-local eshell-command-prefix (make-symbol "eshell-command-prefix")) - (fset eshell-command-prefix (make-sparse-keymap)) - (setq-local eshell-command-map (symbol-function eshell-command-prefix)) - (define-key eshell-mode-map [(control ?c)] eshell-command-prefix) - - (define-key eshell-command-map [(meta ?o)] 'eshell-mark-output) - (define-key eshell-command-map [(meta ?d)] 'eshell-toggle-direct-send) - - (define-key eshell-command-map [(control ?a)] 'eshell-bol) - (define-key eshell-command-map [(control ?b)] 'eshell-backward-argument) - (define-key eshell-command-map [(control ?e)] 'eshell-show-maximum-output) - (define-key eshell-command-map [(control ?f)] 'eshell-forward-argument) - (define-key eshell-command-map [(control ?m)] 'eshell-copy-old-input) - (define-key eshell-command-map [(control ?o)] 'eshell-kill-output) - (define-key eshell-command-map [(control ?r)] 'eshell-show-output) - (define-key eshell-command-map [(control ?t)] 'eshell-truncate-buffer) - (define-key eshell-command-map [(control ?u)] 'eshell-kill-input) - (define-key eshell-command-map [(control ?w)] 'backward-kill-word) - (define-key eshell-command-map [(control ?y)] 'eshell-repeat-argument) - (setq local-abbrev-table eshell-mode-abbrev-table) (set (make-local-variable 'list-buffers-directory) diff --git a/lisp/eshell/esh-proc.el b/lisp/eshell/esh-proc.el index c3ac3a5b71b..d2c17fe1f77 100644 --- a/lisp/eshell/esh-proc.el +++ b/lisp/eshell/esh-proc.el @@ -109,6 +109,16 @@ information, for example." (defvar eshell-process-list nil "A list of the current status of subprocesses.") +(defvar eshell-proc-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-i") #'eshell-insert-process) + (define-key map (kbd "C-c C-c") #'eshell-interrupt-process) + (define-key map (kbd "C-c C-k") #'eshell-kill-process) + (define-key map (kbd "C-c C-d") #'eshell-send-eof-to-process) + (define-key map (kbd "C-c C-s") #'list-processes) + (define-key map (kbd "C-c C-\\") #'eshell-quit-process) + map)) + ;;; Functions: (defun eshell-kill-process-function (proc status) @@ -121,20 +131,16 @@ PROC and STATUS to functions on the latter." (eshell-reset-after-proc status) (run-hook-with-args 'eshell-kill-hook proc status)) +(define-minor-mode eshell-proc-mode + "Minor mode for the proc eshell module. + +\\{eshell-proc-mode-map}" + :keymap eshell-proc-mode-map) + (defun eshell-proc-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the process handling code." (make-local-variable 'eshell-process-list) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?i)] 'eshell-insert-process) - (define-key eshell-command-map [(control ?c)] 'eshell-interrupt-process) - (define-key eshell-command-map [(control ?k)] 'eshell-kill-process) - (define-key eshell-command-map [(control ?d)] 'eshell-send-eof-to-process) -; (define-key eshell-command-map [(control ?q)] 'eshell-continue-process) - (define-key eshell-command-map [(control ?s)] 'list-processes) -; (define-key eshell-command-map [(control ?z)] 'eshell-stop-process) - (define-key eshell-command-map [(control ?\\)] 'eshell-quit-process)) + (eshell-proc-mode)) (defun eshell-reset-after-proc (status) "Reset the command input location after a process terminates. diff --git a/lisp/eshell/esh-util.el b/lisp/eshell/esh-util.el index 0328c1f12fa..ab030ede05b 100644 --- a/lisp/eshell/esh-util.el +++ b/lisp/eshell/esh-util.el @@ -647,14 +647,8 @@ gid format. Valid values are `string' and `integer', defaulting to (let ((base (file-name-nondirectory file)) (dir (file-name-directory file))) (if (string-equal "" base) (setq base ".")) - (if (boundp 'ange-cache) - (setq entry (cdr (assoc base (cdr (assoc dir ange-cache)))))) (unless entry (setq entry (eshell-parse-ange-ls dir)) - (if (boundp 'ange-cache) - (setq ange-cache - (cons (cons dir entry) - ange-cache))) (if entry (let ((fentry (assoc base (cdr entry)))) (if fentry diff --git a/lisp/eshell/esh-var.el b/lisp/eshell/esh-var.el index 75ccf5b8353..96838d41327 100644 --- a/lisp/eshell/esh-var.el +++ b/lisp/eshell/esh-var.el @@ -179,26 +179,50 @@ if they are quoted with a backslash." (eshell-apply-indices eshell-command-arguments indices))))) "This list provides aliasing for variable references. -It is very similar in concept to what `eshell-user-aliases-list' does -for commands. Each member of this defines the name of a command, -and the Lisp value to return for that variable if it is accessed -via the syntax `$NAME'. - -If the value is a function, that function will be called with two -arguments: the list of the indices that was used in the reference, and -whether the user is requesting the length of the ultimate element. -For example, a reference of `$NAME[10][20]' would result in the -function for alias `NAME' being called (assuming it were aliased to a -function), and the arguments passed to this function would be the list -'(10 20)', and nil." +Each member defines the name of a variable, and a Lisp value used to +compute the string value that will be returned when the variable is +accessed via the syntax `$NAME'. + +If the value is a function, call that function with two arguments: the +list of the indices that was used in the reference, and whether the +user is requesting the length of the ultimate element. For example, a +reference of `$NAME[10][20]' would result in the function for alias +`NAME' being called (assuming it were aliased to a function), and the +arguments passed to this function would be the list '(10 20)', and +nil. + +If the value is a string, return the value for the variable with that +name in the current environment. If no variable with that name exists +in the environment, but if a symbol with that same name exists and has +a value bound to it, return its value instead. You can prioritize +symbol values over environment values by setting +`eshell-prefer-lisp-variables' to t. + +If the value is a symbol, return the value bound to it. + +If the value has any other type, signal an error. + +Additionally, each member may specify if it should be copied to the +environment of created subprocesses." :type '(repeat (list string sexp (choice (const :tag "Copy to environment" t) (const :tag "Use only in Eshell" nil))))) (put 'eshell-variable-aliases-list 'risky-local-variable t) +(defvar eshell-var-mode-map + (let ((map (make-sparse-keymap))) + (define-key map (kbd "C-c M-v") #'eshell-insert-envvar) + map)) + ;;; Functions: +(define-minor-mode eshell-var-mode + "Minor mode for the esh-var module. + +\\{eshell-var-mode-map}" + :keymap eshell-var-mode-map) + (defun eshell-var-initialize () ;Called from `eshell-mode' via intern-soft! "Initialize the variable handle code." ;; Break the association with our parent's environment. Otherwise, @@ -207,11 +231,6 @@ function), and the arguments passed to this function would be the list (set (make-local-variable 'process-environment) (eshell-copy-environment))) - ;; This is supposedly run after enabling esh-mode, when eshell-command-map - ;; already exists. - (defvar eshell-command-map) - (define-key eshell-command-map [(meta ?v)] 'eshell-insert-envvar) - (set (make-local-variable 'eshell-special-chars-inside-quoting) (append eshell-special-chars-inside-quoting '(?$))) (set (make-local-variable 'eshell-special-chars-outside-quoting) diff --git a/lisp/eshell/eshell.el b/lisp/eshell/eshell.el index 2a63882ff09..5ffb159b575 100644 --- a/lisp/eshell/eshell.el +++ b/lisp/eshell/eshell.el @@ -265,14 +265,18 @@ information on Eshell, see Info node `(eshell)Top'." (eshell-mode)) buf)) -(defun eshell-return-exits-minibuffer () - ;; This is supposedly run after enabling esh-mode, when eshell-mode-map - ;; already exists. - (defvar eshell-mode-map) - (define-key eshell-mode-map [(control ?g)] 'abort-recursive-edit) - (define-key eshell-mode-map [(control ?m)] 'exit-minibuffer) - (define-key eshell-mode-map [(control ?j)] 'exit-minibuffer) - (define-key eshell-mode-map [(meta control ?m)] 'exit-minibuffer)) +(define-minor-mode eshell-command-mode + "Minor mode for `eshell-command' input. +\\{eshell-command-mode-map}" + :keymap (let ((map (make-sparse-keymap))) + (define-key map [(control ?g)] 'abort-recursive-edit) + (define-key map [(control ?m)] 'exit-minibuffer) + (define-key map [(control ?j)] 'exit-minibuffer) + (define-key map [(meta control ?m)] 'exit-minibuffer) + map)) + +(define-obsolete-function-alias 'eshell-return-exits-minibuffer + #'eshell-command-mode "28.1") (defvar eshell-non-interactive-p nil "A variable which is non-nil when Eshell is not running interactively. @@ -292,7 +296,7 @@ With prefix ARG, insert output into the current buffer at point." ;; Enable `eshell-mode' only in this minibuffer. (minibuffer-with-setup-hook #'(lambda () (eshell-mode) - (eshell-return-exits-minibuffer)) + (eshell-command-mode +1)) (unless command (setq command (read-from-minibuffer "Emacs shell command: ")) (if (eshell-using-module 'eshell-hist) diff --git a/lisp/expand.el b/lisp/expand.el index 1417c90fdb4..77e4fc2657c 100644 --- a/lisp/expand.el +++ b/lisp/expand.el @@ -55,10 +55,8 @@ ;; ;; you can also init some post-process hooks : ;; -;; (add-hook 'expand-load-hook -;; (lambda () -;; (add-hook 'expand-expand-hook 'indent-according-to-mode) -;; (add-hook 'expand-jump-hook 'indent-according-to-mode))) +;; (add-hook 'expand-expand-hook 'indent-according-to-mode) +;; (add-hook 'expand-jump-hook 'indent-according-to-mode) ;; ;; Remarks: ;; @@ -78,6 +76,8 @@ "Hooks run when `expand.el' is loaded." :type 'hook :group 'expand) +(make-obsolete-variable 'expand-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom expand-expand-hook nil "Hooks run when an abbrev made by `expand-add-abbrevs' is expanded." diff --git a/lisp/facemenu.el b/lisp/facemenu.el index b10d874b21b..419b76101b5 100644 --- a/lisp/facemenu.el +++ b/lisp/facemenu.el @@ -621,12 +621,11 @@ color. The function should accept a single argument, the color name." (downcase b)))))) (setq color (list color))) (let* ((opoint (point)) - (color-values (color-values (car color))) - (light-p (>= (apply 'max color-values) - (* (car (color-values "white")) .5)))) + (fg (readable-foreground-color (car color)))) (insert (car color)) (indent-to 22) - (put-text-property opoint (point) 'face `(:background ,(car color))) + (put-text-property opoint (point) 'face `(:background ,(car color) + :foreground ,fg)) (put-text-property (prog1 (point) (insert " ") @@ -639,7 +638,7 @@ color. The function should accept a single argument, the color name." (insert (propertize (apply 'format "#%02x%02x%02x" (mapcar (lambda (c) (ash c -8)) - color-values)) + (color-values (car color)))) 'mouse-face 'highlight 'help-echo (let ((hsv (apply 'color-rgb-to-hsv @@ -651,7 +650,7 @@ color. The function should accept a single argument, the color name." opoint (point) 'follow-link t 'mouse-face (list :background (car color) - :foreground (if light-p "black" "white")) + :foreground fg) 'color-name (car color) 'action callback-fn))) (insert "\n")) diff --git a/lisp/faces.el b/lisp/faces.el index 4d1d9561d49..ba85973bf10 100644 --- a/lisp/faces.el +++ b/lisp/faces.el @@ -1560,7 +1560,7 @@ is given, in which case return its value instead." ;; return it to the caller. Since there will most definitely be something to ;; return in this case, there's no need to know/check if a match was found. (if defaults - (append result defaults) + (append defaults result) (if match-found result no-match-retval)))) @@ -1785,16 +1785,42 @@ with the color they represent as background color." (defined-colors frame))) (defun readable-foreground-color (color) - "Return a readable foreground color for background COLOR." - (let* ((rgb (color-values color)) - (max (apply #'max rgb)) - (black (car (color-values "black"))) - (white (car (color-values "white")))) - ;; Select black or white depending on which one is less similar to - ;; the brightest component. - (if (> (abs (- max black)) (abs (- max white))) - "black" - "white"))) + "Return a readable foreground color for background COLOR. +The returned value is a string representing black or white, depending +on which one provides better contrast with COLOR." + ;; We use #ffffff instead of "white", because the latter is sometimes + ;; less than white. That way, we get the best contrast possible. + (if (color-dark-p (mapcar (lambda (c) (/ c 65535.0)) + (color-values color))) + "#ffffff" "black")) + +(defconst color-luminance-dark-limit 0.325 + "The relative luminance below which a color is considered 'dark'. +A 'dark' color in this sense provides better contrast with white +than with black; see `color-dark-p'. +This value was determined experimentally.") + +(defun color-dark-p (rgb) + "Whether RGB is more readable against white than black. +RGB is a 3-element list (R G B), each component in the range [0,1]. +This predicate can be used both for determining a suitable (black or white) +contrast colour with RGB as background and as foreground." + (unless (<= 0 (apply #'min rgb) (apply #'max rgb) 1) + (error "RGB components %S not in [0,1]" rgb)) + ;; Compute the relative luminance after gamma-correcting (assuming sRGB), + ;; and compare to a cut-off value determined experimentally. + ;; See https://en.wikipedia.org/wiki/Relative_luminance for details. + (let* ((sr (nth 0 rgb)) + (sg (nth 1 rgb)) + (sb (nth 2 rgb)) + ;; Gamma-correct the RGB components to linear values. + ;; Use the power 2.2 as an approximation to sRGB gamma; + ;; it should be good enough for the purpose of this function. + (r (expt sr 2.2)) + (g (expt sg 2.2)) + (b (expt sb 2.2)) + (y (+ (* r 0.2126) (* g 0.7152) (* b 0.0722)))) + (< y color-luminance-dark-limit))) (declare-function xw-color-defined-p "xfns.c" (color &optional frame)) @@ -1822,7 +1848,7 @@ COLOR should be a string naming a color (e.g. \"white\"), or a string specifying a color's RGB components (e.g. \"#ff12ec\"). Return a list of three integers, (RED GREEN BLUE), each between 0 -and either 65280 or 65535 (the maximum depends on the system). +and 65535 inclusive. Use `color-name-to-rgb' if you want RGB floating-point values normalized to 1.0. diff --git a/lisp/ffap.el b/lisp/ffap.el index 66ef0824d8a..ceba9d26223 100644 --- a/lisp/ffap.el +++ b/lisp/ffap.el @@ -54,6 +54,8 @@ ;; C-x 5 r ffap-read-only-other-frame ;; C-x 5 d ffap-dired-other-frame ;; +;; C-x t f ffap-other-tab +;; ;; S-mouse-3 ffap-at-mouse ;; C-S-mouse-3 ffap-menu ;; @@ -1080,7 +1082,7 @@ If a given RFC isn't in these then `ffap-rfc-path' is offered." ;; Slightly controversial decisions: ;; * strip trailing "@", ":" and enclosing "{"/"}". ;; * no commas (good for latex) - (file "--:\\\\${}+<>@-Z_[:alpha:]~*?" "{<@" "@>;.,!:}") + (file "--:\\\\${}+<>@-Z_[:alpha:]~*?#" "{<@" "@>;.,!:}") ;; An url, or maybe an email/news message-id: (url "--:=&?$+@-Z_[:alpha:]~#,%;*()!'" "^[0-9a-zA-Z]" ":;.,!?") ;; Find a string that does *not* contain a colon: @@ -1607,7 +1609,7 @@ Each ALIST entry looks like (STRING . DATA) and defines one choice. Function CONT is applied to the entry chosen by the user." ;; Note: this function is used with a different continuation ;; by the ffap-url add-on package. - ;; Could try rewriting to use easymenu.el or lmenu.el. + ;; Could try rewriting to use easymenu.el. (let (choice) (cond ;; Emacs mouse: @@ -1758,6 +1760,14 @@ Only intended for interactive use." (set-window-dedicated-p win wdp)) value)) +(defun ffap-other-tab (filename) + "Like `ffap', but put buffer in another tab. +Only intended for interactive use." + (interactive (list (ffap-prompter nil " other tab"))) + (pcase (save-window-excursion (find-file-at-point filename)) + ((or (and (pred bufferp) b) `(,(and (pred bufferp) b) . ,_)) + (switch-to-buffer-other-tab b)))) + (defun ffap--toggle-read-only (buffer-or-list) (dolist (buffer (if (listp buffer-or-list) buffer-or-list @@ -2013,6 +2023,7 @@ This hook is intended to be put in `file-name-at-point-functions'." (global-set-key [remap find-file-other-window] 'ffap-other-window) (global-set-key [remap find-file-other-frame] 'ffap-other-frame) + (global-set-key [remap find-file-other-tab] 'ffap-other-tab) (global-set-key [remap find-file-read-only-other-window] 'ffap-read-only-other-window) (global-set-key [remap find-file-read-only-other-frame] 'ffap-read-only-other-frame) diff --git a/lisp/fileloop.el b/lisp/fileloop.el index 833bb0401cb..d52e35d886f 100644 --- a/lisp/fileloop.el +++ b/lisp/fileloop.el @@ -201,30 +201,34 @@ operating on the next file and nil otherwise." ;;;###autoload (defun fileloop-initialize-replace (from to files case-fold &optional delimited) "Initialize a new round of query&replace on several files. - FROM is a regexp and TO is the replacement to use. - FILES describes the files, as in `fileloop-initialize'. - CASE-FOLD can be t, nil, or `default': - if it is nil, matching of FROM is case-sensitive. - if it is t, matching of FROM is case-insensitive, except - when `search-upper-case' is non-nil and FROM includes - upper-case letters. - if it is `default', the function uses the value of - `case-fold-search' instead. - DELIMITED if non-nil means replace only word-delimited matches." +FROM is a regexp and TO is the replacement to use. +FILES describes the files, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default': + if it is nil, matching of FROM is case-sensitive. + if it is t, matching of FROM is case-insensitive, except + when `search-upper-case' is non-nil and FROM includes + upper-case letters. + if it is `default', the function uses the value of + `case-fold-search' instead. +DELIMITED if non-nil means replace only word-delimited matches." ;; FIXME: Not sure how the delimited-flag interacts with the regexp-flag in ;; `perform-replace', so I just try to mimic the old code. - (fileloop-initialize - files - (lambda () - (let ((case-fold-search (fileloop--case-fold from case-fold))) - (if (re-search-forward from nil t) - ;; When we find a match, move back - ;; to the beginning of it so perform-replace - ;; will see it. - (goto-char (match-beginning 0))))) - (lambda () - (let ((case-fold-search (fileloop--case-fold from case-fold))) - (perform-replace from to t t delimited nil multi-query-replace-map))))) + (let ((mstart (make-hash-table :test 'eq))) + (fileloop-initialize + files + (lambda () + (let ((case-fold-search (fileloop--case-fold from case-fold))) + (when (re-search-forward from nil t) + ;; When we find a match, save its beginning for + ;; `perform-replace' (we used to just set point, but this + ;; is unreliable in the face of + ;; `switch-to-buffer-preserve-window-point'). + (puthash (current-buffer) (match-beginning 0) mstart)))) + (lambda () + (let ((case-fold-search (fileloop--case-fold from case-fold))) + (perform-replace from to t t delimited nil multi-query-replace-map + (gethash (current-buffer) mstart (point-min)) + (point-max))))))) (provide 'fileloop) ;;; fileloop.el ends here diff --git a/lisp/files.el b/lisp/files.el index 3e4ad7c0d44..742fd78df1d 100644 --- a/lisp/files.el +++ b/lisp/files.el @@ -405,7 +405,7 @@ editing a remote file. On MS-DOS filesystems without long names this variable is always ignored." :group 'auto-save - :type '(repeat (list (string :tag "Regexp") (string :tag "Replacement") + :type '(repeat (list (regexp :tag "Regexp") (string :tag "Replacement") (boolean :tag "Uniquify"))) :initialize 'custom-initialize-delay :version "21.1") @@ -430,7 +430,13 @@ idle for `auto-save-visited-interval' seconds." Unlike `auto-save-mode', this mode will auto-save buffer contents to the visited files directly and will also run all save-related -hooks. See Info node `Saving' for details of the save process." +hooks. See Info node `Saving' for details of the save process. + +You can also set the buffer-local value of the variable +`auto-save-visited-mode' to nil. A buffer where the buffer-local +value of this variable is nil is ignored for the purpose of +`auto-save-visited-mode', even if `auto-save-visited-mode' is +enabled." :group 'auto-save :global t (when auto-save--timer (cancel-timer auto-save--timer)) @@ -441,6 +447,7 @@ hooks. See Info node `Saving' for details of the save process." #'save-some-buffers :no-prompt (lambda () (and buffer-file-name + auto-save-visited-mode (not (and buffer-auto-save-file-name auto-save-visited-file-name)))))))) @@ -1094,6 +1101,8 @@ REMOTE is non-nil, search on the remote host indicated by (let ((default-directory (file-name-quote default-directory 'top))) (locate-file command exec-path exec-suffixes 1)))) +(declare-function read-library-name "find-func" nil) + (defun load-library (library) "Load the Emacs Lisp library named LIBRARY. LIBRARY should be a string. @@ -1103,12 +1112,7 @@ well as `load-file-rep-suffixes'). See Info node `(emacs)Lisp Libraries' for more details. See `load-file' for a different interface to `load'." - (interactive - (let (completion-ignored-extensions) - (list (completing-read "Load library: " - (apply-partially 'locate-file-completion-table - load-path - (get-load-suffixes)))))) + (interactive (list (read-library-name))) (load library)) (defun file-remote-p (file &optional identification connected) @@ -1917,6 +1921,8 @@ killed." (setq buffer-file-truename otrue) (setq dired-directory odir) (lock-buffer) + (if (get-buffer oname) + (kill-buffer oname)) (rename-buffer oname))) (unless (eq (current-buffer) obuf) (with-current-buffer obuf @@ -2660,6 +2666,13 @@ since only a single case-insensitive search through the alist is made." ("\\.ltx\\'" . latex-mode) ("\\.dtx\\'" . doctex-mode) ("\\.org\\'" . org-mode) + ;; .dir-locals.el is not really Elisp. Could use the + ;; `dir-locals-file' constant if it weren't defined below. + ("\\.dir-locals\\(?:-2\\)?\\.el\\'" . lisp-data-mode) + ("eww-bookmarks\\'" . lisp-data-mode) + ("tramp\\'" . lisp-data-mode) + ("places\\'" . lisp-data-mode) + ("\\.emacs-places\\'" . lisp-data-mode) ("\\.el\\'" . emacs-lisp-mode) ("Project\\.ede\\'" . emacs-lisp-mode) ("\\.\\(scm\\|stk\\|ss\\|sch\\)\\'" . scheme-mode) @@ -4674,6 +4687,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." ;; Create temp files with strict access rights. It's easy to ;; loosen them later, whereas it's impossible to close the ;; time-window of loose permissions otherwise. + (let (nofollow-flag) (with-file-modes ?\700 (when (condition-case nil ;; Try to overwrite old backup first. @@ -4684,6 +4698,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (when (file-exists-p to-name) (delete-file to-name)) (copy-file from-name to-name nil t t) + (setq nofollow-flag 'nofollow) nil) (file-already-exists t)) ;; The file was somehow created by someone else between @@ -4696,7 +4711,7 @@ BACKUPNAME is the backup file name, which is the old file renamed." (with-demoted-errors (set-file-extended-attributes to-name extended-attributes))) (and modes - (set-file-modes to-name (logand modes #o1777))))) + (set-file-modes to-name (logand modes #o1777) nofollow-flag))))) (defvar file-name-version-regexp "\\(?:~\\|\\.~[-[:alnum:]:#@^._]+\\(?:~[[:digit:]]+\\)?~\\)" @@ -5755,7 +5770,10 @@ If called interactively, then PARENTS is non-nil." (defconst directory-files-no-dot-files-regexp "[^.]\\|\\.\\.\\." - "Regexp matching any file name except \".\" and \"..\".") + "Regexp matching any file name except \".\" and \"..\". +More precisely, it matches parts of any nonempty string except those two. +It is useful as the regexp argument to `directory-files' and +`directory-files-and-attributes'.") (defun files--force (no-such fn &rest args) "Use NO-SUCH to affect behavior of function FN applied to list ARGS. @@ -5902,7 +5920,8 @@ into NEWNAME instead." ;; If default-directory is a remote directory, make sure we find its ;; copy-directory handler. (let ((handler (or (find-file-name-handler directory 'copy-directory) - (find-file-name-handler newname 'copy-directory)))) + (find-file-name-handler newname 'copy-directory))) + (follow parents)) (if handler (funcall handler 'copy-directory directory newname keep-time parents copy-contents) @@ -5922,7 +5941,8 @@ into NEWNAME instead." (or parents (not (file-directory-p newname))) (setq newname (concat newname (file-name-nondirectory directory)))) - (make-directory (directory-file-name newname) parents))) + (make-directory (directory-file-name newname) parents)) + (t (setq follow t))) ;; Copy recursively. (dolist (file @@ -5942,9 +5962,10 @@ into NEWNAME instead." ;; Set directory attributes. (let ((modes (file-modes directory)) (times (and keep-time (file-attribute-modification-time - (file-attributes directory))))) - (if modes (set-file-modes newname modes)) - (if times (set-file-times newname times)))))) + (file-attributes directory)))) + (follow-flag (unless follow 'nofollow))) + (if modes (set-file-modes newname modes follow-flag)) + (if times (set-file-times newname times follow-flag)))))) ;; At time of writing, only info uses this. @@ -7250,10 +7271,15 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq active t)) (setq processes (cdr processes))) (or (not active) - (with-displayed-buffer-window + (with-current-buffer-window (get-buffer-create "*Process List*") - '(display-buffer--maybe-at-bottom - (dedicated . t)) + `(display-buffer--maybe-at-bottom + (dedicated . t) + (window-height . fit-window-to-buffer) + (preserve-size . (nil . t)) + (body-function + . ,#'(lambda (_window) + (list-processes t)))) #'(lambda (window _value) (with-selected-window window (unwind-protect @@ -7261,8 +7287,7 @@ if any returns nil. If `confirm-kill-emacs' is non-nil, calls it." (setq confirm nil) (yes-or-no-p "Active processes exist; kill them and exit anyway? ")) (when (window-live-p window) - (quit-restore-window window 'kill))))) - (list-processes t))))) + (quit-restore-window window 'kill))))))))) ;; Query the user for other things, perhaps. (run-hook-with-args-until-failure 'kill-emacs-query-functions) (or (null confirm) @@ -7536,6 +7561,27 @@ as in \"og+rX-w\"." op char-right))) num-rights)) +(defun file-modes-number-to-symbolic (mode) + (string + (if (zerop (logand 8192 mode)) + (if (zerop (logand 16384 mode)) ?- ?d) + ?c) ; completeness + (if (zerop (logand 256 mode)) ?- ?r) + (if (zerop (logand 128 mode)) ?- ?w) + (if (zerop (logand 64 mode)) + (if (zerop (logand 2048 mode)) ?- ?S) + (if (zerop (logand 2048 mode)) ?x ?s)) + (if (zerop (logand 32 mode)) ?- ?r) + (if (zerop (logand 16 mode)) ?- ?w) + (if (zerop (logand 8 mode)) + (if (zerop (logand 1024 mode)) ?- ?S) + (if (zerop (logand 1024 mode)) ?x ?s)) + (if (zerop (logand 4 mode)) ?- ?r) + (if (zerop (logand 2 mode)) ?- ?w) + (if (zerop (logand 512 mode)) + (if (zerop (logand 1 mode)) ?- ?x) + (if (zerop (logand 1 mode)) ?T ?t)))) + (defun file-modes-symbolic-to-number (modes &optional from) "Convert symbolic file modes to numeric file modes. MODES is the string to convert, it should match diff --git a/lisp/filesets.el b/lisp/filesets.el index 9834bcf0587..1ec0d24b539 100644 --- a/lisp/filesets.el +++ b/lisp/filesets.el @@ -1645,10 +1645,10 @@ Replace <file-name> or <<file-name>> with filename." (dolist (this args txt) (setq txt (concat txt + (if (equal txt "") "" " ") (filesets-run-cmd--repl-fn this (lambda (this) - (if (equal txt "") "" " ") (format "%s" this)))))))) (cmd (concat fn " " args))) (filesets-cmd-show-result diff --git a/lisp/finder.el b/lisp/finder.el index 71f8ac740ee..f04d73e098f 100644 --- a/lisp/finder.el +++ b/lisp/finder.el @@ -394,13 +394,6 @@ FILE should be in a form suitable for passing to `locate-library'." (erase-buffer) (insert str) (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-max)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^;+ ?" nil t) - (replace-match "" nil nil)) - (goto-char (point-min)) (while (re-search-forward "\\<\\([-[:alnum:]]+\\.el\\)\\>" nil t) (if (locate-library (match-string 1)) (make-text-button (match-beginning 1) (match-end 1) diff --git a/lisp/font-lock.el b/lisp/font-lock.el index 506c888ff64..5cda4a693db 100644 --- a/lisp/font-lock.el +++ b/lisp/font-lock.el @@ -575,6 +575,7 @@ This is normally set via `font-lock-defaults'.") "Non-nil means use this syntax table for fontifying. If this is nil, the major mode's syntax table is used. This is normally set via `font-lock-defaults'.") +(defvar-local font-lock--syntax-table-affects-ppss nil) (defvar font-lock-mark-block-function nil "Non-nil means use this function to mark a block of text. @@ -1120,9 +1121,10 @@ locking for a mode, and is not meant to be called from lisp functions." "Make sure the region BEG...END has been fontified. If the region is not specified, it defaults to the entire accessible portion of the buffer." - (font-lock-set-defaults) - (funcall font-lock-ensure-function - (or beg (point-min)) (or end (point-max)))) + (when (font-lock-specified-p t) + (font-lock-set-defaults) + (funcall font-lock-ensure-function + (or beg (point-min)) (or end (point-max))))) (defun font-lock-default-fontify-buffer () "Fontify the whole buffer using `font-lock-fontify-region-function'." @@ -1609,7 +1611,15 @@ START should be at the beginning of a line." (regexp-quote (replace-regexp-in-string "^ *" "" comment-end)))) ;; Find the `start' state. - (state (syntax-ppss start)) + (state (if (or syntax-ppss-table + (not font-lock--syntax-table-affects-ppss)) + (syntax-ppss start) + ;; If `syntax-ppss' doesn't have its own syntax-table and + ;; we have installed our own syntax-table which + ;; differs from the standard one in ways which affects PPSS, + ;; then we can't use `syntax-ppss' since that would pollute + ;; and be polluted by its cache. + (parse-partial-sexp (point-min) start))) face beg) (if loudly (message "Fontifying %s... (syntactically...)" (buffer-name))) ;; @@ -1906,6 +1916,7 @@ Sets various variables using `font-lock-defaults' and ;; Case fold during regexp fontification? (setq-local font-lock-keywords-case-fold-search (nth 2 defaults)) ;; Syntax table for regexp and syntactic fontification? + (kill-local-variable 'font-lock--syntax-table-affects-ppss) (if (null (nth 3 defaults)) (setq-local font-lock-syntax-table nil) (setq-local font-lock-syntax-table (copy-syntax-table (syntax-table))) @@ -1915,7 +1926,14 @@ Sets various variables using `font-lock-defaults' and (dolist (char (if (numberp (car selem)) (list (car selem)) (mapcar #'identity (car selem)))) - (modify-syntax-entry char syntax font-lock-syntax-table))))) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + (modify-syntax-entry char syntax font-lock-syntax-table) + (unless (memq (car (aref font-lock-syntax-table char)) + '(1 2 3)) ;"." "w" "_" + (setq font-lock--syntax-table-affects-ppss t)) + )))) ;; (nth 4 defaults) used to hold `font-lock-beginning-of-syntax-function', ;; but that was removed in 25.1, so if it's a cons cell, we assume that ;; it's part of the variable alist. diff --git a/lisp/format-spec.el b/lisp/format-spec.el index 9278bd74c42..6af79a44167 100644 --- a/lisp/format-spec.el +++ b/lisp/format-spec.el @@ -1,4 +1,4 @@ -;;; format-spec.el --- functions for formatting arbitrary formatting strings +;;; format-spec.el --- format arbitrary formatting strings -*- lexical-binding: t -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -24,10 +24,8 @@ ;;; Code: -(eval-when-compile - (require 'subr-x)) - -(defun format-spec (format specification &optional only-present) +;;;###autoload +(defun format-spec (format specification &optional ignore-missing) "Return a string based on FORMAT and SPECIFICATION. FORMAT is a string containing `format'-like specs like \"su - %u %k\". SPECIFICATION is an alist mapping format specification characters @@ -39,22 +37,22 @@ For instance: \\=`((?u . ,(user-login-name)) (?l . \"ls\"))) -Each %-spec may contain optional flag and width modifiers, as -follows: +Each %-spec may contain optional flag, width, and precision +modifiers, as follows: - %<flags><width>character + %<flags><width><precision>character The following flags are allowed: * 0: Pad to the width, if given, with zeros instead of spaces. * -: Pad to the width, if given, on the right instead of the left. -* <: Truncate to the width, if given, on the left. -* >: Truncate to the width, if given, on the right. +* <: Truncate to the width and precision, if given, on the left. +* >: Truncate to the width and precision, if given, on the right. * ^: Convert to upper case. * _: Convert to lower case. -The width modifier behaves like the corresponding one in `format' -when applied to %s. +The width and truncation modifiers behave like the corresponding +ones in `format' when applied to %s. For example, \"%<010b\" means \"substitute into the output the value associated with ?b in SPECIFICATION, either padding it with @@ -64,89 +62,108 @@ characters wide\". Any text properties of FORMAT are copied to the result, with any text properties of a %-spec itself copied to its substitution. -ONLY-PRESENT indicates how to handle %-spec characters not +IGNORE-MISSING indicates how to handle %-spec characters not present in SPECIFICATION. If it is nil or omitted, emit an -error; otherwise leave those %-specs and any occurrences of -\"%%\" in FORMAT verbatim in the result, including their text -properties, if any." +error; if it is the symbol `ignore', leave those %-specs verbatim +in the result, including their text properties, if any; if it is +the symbol `delete', remove those %-specs from the result; +otherwise do the same as for the symbol `ignore', but also leave +any occurrences of \"%%\" in FORMAT verbatim in the result." (with-temp-buffer (insert format) (goto-char (point-min)) (while (search-forward "%" nil t) (cond - ;; Quoted percent sign. - ((eq (char-after) ?%) - (unless only-present - (delete-char 1))) - ;; Valid format spec. - ((looking-at "\\([-0 _^<>]*\\)\\([0-9.]*\\)\\([a-zA-Z]\\)") - (let* ((modifiers (match-string 1)) - (num (match-string 2)) - (spec (string-to-char (match-string 3))) - (val (assq spec specification))) - (if (not val) - (unless only-present - (error "Invalid format character: `%%%c'" spec)) - (setq val (cdr val) - modifiers (format-spec--parse-modifiers modifiers)) - ;; Pad result to desired length. - (let ((text (format "%s" val))) - (when num - (setq num (string-to-number num)) - (setq text (format-spec--pad text num modifiers)) - (when (> (length text) num) - (cond - ((memq :chop-left modifiers) - (setq text (substring text (- (length text) num)))) - ((memq :chop-right modifiers) - (setq text (substring text 0 num)))))) - (when (memq :uppercase modifiers) - (setq text (upcase text))) - (when (memq :lowercase modifiers) - (setq text (downcase text))) - ;; Insert first, to preserve text properties. - (insert-and-inherit text) - ;; Delete the specifier body. - (delete-region (+ (match-beginning 0) (length text)) - (+ (match-end 0) (length text))) - ;; Delete the percent sign. - (delete-region (1- (match-beginning 0)) (match-beginning 0)))))) - ;; Signal an error on bogus format strings. - (t - (unless only-present - (error "Invalid format string"))))) + ;; Quoted percent sign. + ((= (following-char) ?%) + (when (memq ignore-missing '(nil ignore delete)) + (delete-char 1))) + ;; Valid format spec. + ((looking-at (rx (? (group (+ (in " 0<>^_-")))) + (? (group (+ digit))) + (? (group ?. (+ digit))) + (group alpha))) + (let* ((beg (point)) + (end (match-end 0)) + (flags (match-string 1)) + (width (match-string 2)) + (trunc (match-string 3)) + (char (string-to-char (match-string 4))) + (text (assq char specification))) + (cond (text + ;; Handle flags. + (setq text (format-spec--do-flags + (format "%s" (cdr text)) + (format-spec--parse-flags flags) + (and width (string-to-number width)) + (and trunc (car (read-from-string trunc 1))))) + ;; Insert first, to preserve text properties. + (insert-and-inherit text) + ;; Delete the specifier body. + (delete-region (point) (+ end (length text))) + ;; Delete the percent sign. + (delete-region (1- beg) beg)) + ((eq ignore-missing 'delete) + ;; Delete the whole format spec. + (delete-region (1- beg) end)) + ((not ignore-missing) + (error "Invalid format character: `%%%c'" char))))) + ;; Signal an error on bogus format strings. + ((not ignore-missing) + (error "Invalid format string")))) (buffer-string))) -(defun format-spec--pad (text total-length modifiers) - (if (> (length text) total-length) - ;; The text is longer than the specified length; do nothing. - text - (let ((padding (make-string (- total-length (length text)) - (if (memq :zero-pad modifiers) - ?0 - ?\s)))) - (if (memq :right-pad modifiers) - (concat text padding) - (concat padding text))))) - -(defun format-spec--parse-modifiers (modifiers) +(defun format-spec--do-flags (str flags width trunc) + "Return STR formatted according to FLAGS, WIDTH, and TRUNC. +FLAGS is a list of keywords as returned by +`format-spec--parse-flags'. WIDTH and TRUNC are either nil or +string widths corresponding to `format-spec' modifiers." + (let (diff str-width) + ;; Truncate original string first, like `format' does. + (when trunc + (setq str-width (string-width str)) + (when (> (setq diff (- str-width trunc)) 0) + (setq str (if (memq :chop-left flags) + (truncate-string-to-width str str-width diff) + (format (format "%%.%ds" trunc) str)) + ;; We know the new width so save it for later. + str-width trunc))) + ;; Pad or chop to width. + (when width + (setq str-width (or str-width (string-width str)) + diff (- width str-width)) + (cond ((zerop diff)) + ((> diff 0) + (let ((pad (make-string diff (if (memq :pad-zero flags) ?0 ?\s)))) + (setq str (if (memq :pad-right flags) + (concat str pad) + (concat pad str))))) + ((memq :chop-left flags) + (setq str (truncate-string-to-width str str-width (- diff)))) + ((memq :chop-right flags) + (setq str (format (format "%%.%ds" width) str)))))) + ;; Fiddle case. + (cond ((memq :upcase flags) + (upcase str)) + ((memq :downcase flags) + (downcase str)) + (str))) + +(defun format-spec--parse-flags (flags) + "Convert sequence of FLAGS to list of human-readable keywords." (mapcan (lambda (char) - (when-let ((modifier - (pcase char - (?0 :zero-pad) - (?\s :space-pad) - (?^ :uppercase) - (?_ :lowercase) - (?- :right-pad) - (?< :chop-left) - (?> :chop-right)))) - (list modifier))) - modifiers)) + (pcase char + (?0 (list :pad-zero)) + (?- (list :pad-right)) + (?< (list :chop-left)) + (?> (list :chop-right)) + (?^ (list :upcase)) + (?_ (list :downcase)))) + flags)) (defun format-spec-make (&rest pairs) "Return an alist suitable for use in `format-spec' based on PAIRS. -PAIRS is a list where every other element is a character and a value, -starting with a character." +PAIRS is a property list with characters as keys." (let (alist) (while pairs (unless (cdr pairs) diff --git a/lisp/frame.el b/lisp/frame.el index 16ee7580f89..081d3010e9b 100644 --- a/lisp/frame.el +++ b/lisp/frame.el @@ -713,6 +713,18 @@ The optional argument PARAMETERS specifies additional frame parameters." (x-display-list)))) (make-frame (cons (cons 'display display) parameters))) +(defun make-frame-on-current-monitor (&optional parameters) + "Make a frame on the currently selected monitor. +Like `make-frame-on-monitor' and with the same PARAMETERS as in `make-frame'." + (interactive) + (let* ((monitor-workarea + (cdr (assq 'workarea (frame-monitor-attributes)))) + (geometry-parameters + (when monitor-workarea + `((top . ,(nth 1 monitor-workarea)) + (left . ,(nth 0 monitor-workarea)))))) + (make-frame (append geometry-parameters parameters)))) + (defun make-frame-on-monitor (monitor &optional display parameters) "Make a frame on monitor MONITOR. The optional argument DISPLAY can be a display name, and the optional @@ -1058,6 +1070,23 @@ that variable should be nil." (setq arg (1+ arg))) (select-frame-set-input-focus frame))) +(defun other-frame-prefix () + "Display the buffer of the next command in a new frame. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new frame before displaying the buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (cons (display-buffer-pop-up-frame + buffer (append '((inhibit-same-window . t)) + alist)) + 'frame)) + nil "[other-frame]") + (message "Display next command buffer in a new frame...")) + (defun iconify-or-deiconify-frame () "Iconify the selected frame, or deiconify if it's currently an icon." (interactive) @@ -2676,11 +2705,7 @@ See also `toggle-frame-maximized'." (set-frame-parameter frame 'fullscreen fullscreen-restore) (set-frame-parameter frame 'fullscreen nil))) (modify-frame-parameters - frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))) - ;; Manipulating a frame without waiting for the fullscreen - ;; animation to complete can cause a crash, or other unexpected - ;; behavior, on macOS (bug#28496). - (when (featurep 'cocoa) (sleep-for 0.5)))) + frame `((fullscreen . fullboth) (fullscreen-restore . ,fullscreen)))))) ;;;; Key bindings @@ -2689,6 +2714,7 @@ See also `toggle-frame-maximized'." (define-key ctl-x-5-map "1" 'delete-other-frames) (define-key ctl-x-5-map "0" 'delete-frame) (define-key ctl-x-5-map "o" 'other-frame) +(define-key ctl-x-5-map "5" 'other-frame-prefix) (define-key global-map [f11] 'toggle-frame-fullscreen) (define-key global-map [(meta f10)] 'toggle-frame-maximized) (define-key esc-map [f10] 'toggle-frame-maximized) diff --git a/lisp/frameset.el b/lisp/frameset.el index 10c6914f52d..0462d776c0e 100644 --- a/lisp/frameset.el +++ b/lisp/frameset.el @@ -396,17 +396,17 @@ Properties can be set with ;; or, if you're only changing a few items, ;; ;; (defvar my-filter-alist -;; (nconc '((my-param1 . :never) -;; (my-param2 . my-filtering-function)) -;; frameset-filter-alist) +;; (append '((my-param1 . :never) +;; (my-param2 . my-filtering-function)) +;; frameset-filter-alist) ;; "My brief customized parameter filter alist.") ;; ;; and pass it to the FILTER arg of the save/restore functions, ;; ALWAYS taking care of not modifying the original lists; if you're ;; going to do any modifying of my-filter-alist, please use ;; -;; (nconc '((my-param1 . :never) ...) -;; (copy-sequence frameset-filter-alist)) +;; (append '((my-param1 . :never) ...) +;; (copy-sequence frameset-filter-alist)) ;; ;; One thing you shouldn't forget is that they are alists, so searching ;; in them is sequential. If you just want to change the default of @@ -445,7 +445,7 @@ DO NOT MODIFY. See `frameset-filter-alist' for a full description.") ;;;###autoload (defvar frameset-persistent-filter-alist - (nconc + (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) diff --git a/lisp/gnus/deuglify.el b/lisp/gnus/deuglify.el index 82dbbab5e0d..647f643c962 100644 --- a/lisp/gnus/deuglify.el +++ b/lisp/gnus/deuglify.el @@ -266,21 +266,21 @@ "\\(On \\|Am \\)?\\(Mon\\|Tue\\|Wed\\|Thu\\|Fri\\|Sat\\|Sun\\),[^,]+, " "Regular expression matching the beginning of an attribution line that should be cut off." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-verb-regexp "wrote\\|writes\\|says\\|schrieb\\|schreibt\\|meinte\\|skrev\\|a écrit\\|schreef\\|escribió" "Regular expression matching the verb used in an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-deuglify-attrib-end-regexp ": *\\|\\.\\.\\." "Regular expression matching the end of an attribution line." :version "22.1" - :type 'string + :type 'regexp :group 'gnus-outlook-deuglify) (defcustom gnus-outlook-display-hook nil @@ -403,9 +403,9 @@ NODISPLAY is non-nil, don't redisplay the article buffer." (gnus-with-article-buffer (article-goto-body) (when (re-search-forward - (concat "^[" cite-marks " \t]*--* ?[^-]+ [^-]+ ?--*\\s *\n" + (concat "^[" cite-marks " \t]*--*[^-]+ [^-]+--*\\s *\n" "[^\n:]+:[ \t]*\\([^\n]+\\)\n" - "\\([^\n:]+:[ \t]*[^\n]+\n\\)+") + "\\([^\n:]+:[^\n]+\n\\)+") nil t) (gnus-kill-all-overlays) (replace-match "\\1 wrote:\n") diff --git a/lisp/gnus/gmm-utils.el b/lisp/gnus/gmm-utils.el index 2df098bc0bf..6d24b409ed0 100644 --- a/lisp/gnus/gmm-utils.el +++ b/lisp/gnus/gmm-utils.el @@ -168,9 +168,9 @@ ARGS are passed to `message'." (defcustom gmm-tool-bar-style (if (and (boundp 'tool-bar-mode) tool-bar-mode - (memq (display-visual-class) - (list 'static-gray 'gray-scale - 'static-color 'pseudo-color))) + (not (memq (display-visual-class) + (list 'static-gray 'gray-scale + 'static-color 'pseudo-color)))) 'gnome 'retro) "Preferred tool bar style." diff --git a/lisp/gnus/gnus-agent.el b/lisp/gnus/gnus-agent.el index cf705ae5dc1..88873f47bd5 100644 --- a/lisp/gnus/gnus-agent.el +++ b/lisp/gnus/gnus-agent.el @@ -603,11 +603,22 @@ manipulated as follows: (gnus)) ;;;###autoload +(defun gnus-child-unplugged (&optional arg) + "Read news as a child unplugged." + (interactive "P") + (setq gnus-plugged nil) + (gnus arg nil 'child)) + +;;;###autoload (defun gnus-slave-unplugged (&optional arg) - "Read news as a slave unplugged." + "Read news as a child unplugged." (interactive "P") (setq gnus-plugged nil) - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave-unplugged 'gnus-child-unplugged "28.1") + + + ;;;###autoload (defun gnus-agentize () @@ -799,7 +810,7 @@ be a select method." (let ((gnus-command-method method) (gnus-agent nil)) (when (file-exists-p (gnus-agent-lib-file "flags")) - (set-buffer (get-buffer-create " *Gnus Agent flag synchronize*")) + (set-buffer (gnus-get-buffer-create " *Gnus Agent flag synchronize*")) (erase-buffer) (nnheader-insert-file-contents (gnus-agent-lib-file "flags")) (cond ((null gnus-plugged) diff --git a/lisp/gnus/gnus-art.el b/lisp/gnus/gnus-art.el index 6b9610d3121..cb20d7102bd 100644 --- a/lisp/gnus/gnus-art.el +++ b/lisp/gnus/gnus-art.el @@ -2303,21 +2303,27 @@ long lines if and only if arg is positive." "\n") (put-text-property start (point) 'gnus-decoration 'header))))) -(defun article-fill-long-lines () - "Fill lines that are wider than the window width." - (interactive) +(defun article-fill-long-lines (&optional width) + "Fill lines that are wider than the window width or `fill-column'. +If WIDTH (interactively, the numeric prefix), use that as the +fill width." + (interactive "P") (save-excursion - (let ((inhibit-read-only t) - (width (window-width (get-buffer-window (current-buffer))))) + (let* ((inhibit-read-only t) + (window-width (window-width (get-buffer-window (current-buffer)))) + (width (if width + (prefix-numeric-value width) + (min fill-column window-width)))) (save-restriction (article-goto-body) (let ((adaptive-fill-mode nil)) ;Why? -sm (while (not (eobp)) (end-of-line) - (when (>= (current-column) (min fill-column width)) + (when (>= (current-column) width) (narrow-to-region (min (1+ (point)) (point-max)) (point-at-bol)) - (let ((goback (point-marker))) + (let ((goback (point-marker)) + (fill-column width)) (fill-paragraph nil) (goto-char (marker-position goback))) (widen)) @@ -4406,6 +4412,7 @@ If variable `gnus-use-long-file-name' is non-nil, it is "e" gnus-article-read-summary-keys "\C-d" gnus-article-read-summary-keys + "\C-c\C-f" gnus-summary-mail-forward "\M-*" gnus-article-read-summary-keys "\M-#" gnus-article-read-summary-keys "\M-^" gnus-article-read-summary-keys @@ -5833,6 +5840,7 @@ all parts." "" "...")) (gnus-tmp-length (with-current-buffer (mm-handle-buffer handle) (buffer-size))) + (help-echo "mouse-2: toggle the MIME part; down-mouse-3: more options") gnus-tmp-type-long b e) (when (string-match ".*/" gnus-tmp-name) (setq gnus-tmp-name (replace-match "" t t gnus-tmp-name))) @@ -5841,6 +5849,16 @@ all parts." (concat "; " gnus-tmp-name)))) (unless (equal gnus-tmp-description "") (setq gnus-tmp-type-long (concat " --- " gnus-tmp-type-long))) + (when (zerop gnus-tmp-length) + (setq gnus-tmp-type-long + (concat + gnus-tmp-type-long + (substitute-command-keys + (concat "\\<gnus-summary-mode-map> (not downloaded, " + "\\[gnus-summary-show-complete-article] to fetch.)")))) + (setq help-echo + (concat "Type \\[gnus-summary-show-complete-article] " + "to download complete article. " help-echo))) (setq b (point)) (gnus-eval-format gnus-mime-button-line-format gnus-mime-button-line-format-alist @@ -5859,8 +5877,7 @@ all parts." 'keymap gnus-mime-button-map 'face gnus-article-button-face 'follow-link t - 'help-echo - "mouse-2: toggle the MIME part; down-mouse-3: more options"))) + 'help-echo help-echo))) (defvar gnus-displaying-mime nil) @@ -6664,7 +6681,7 @@ not have a face in `gnus-article-boring-faces'." (interactive "P") (gnus-article-check-buffer) (let ((nosaves - '("q" "Q" "r" "\C-c\C-f" "m" "a" "f" "WDD" "WDW" + '("q" "Q" "r" "m" "a" "f" "WDD" "WDW" "Zc" "ZC" "ZE" "ZQ" "ZZ" "Zn" "ZR" "ZG" "ZN" "ZP" "=" "^" "\M-^" "|")) (nosave-but-article @@ -7708,6 +7725,15 @@ positives are possible." 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-variable 1) ("M-x[ \t\n]+apropos-documentation[ \t\n]+RET[ \t\n]+\\([^ \t\n]+\\)[ \t\n]+RET\\>" 0 (>= gnus-button-emacs-level 1) gnus-button-handle-apropos-documentation 1) + ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... + ("<URL: *\\([^\n<>]*\\)>" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; RFC 2396 (2.4.3., delims) ... + ("\"URL: *\\([^\n\"]*\\)\"" + 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) + ;; Raw URLs. + (gnus-button-url-regexp + 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; The following entries may lead to many false positives so don't enable ;; them by default (use a high button level). ("/\\([a-z][-a-z0-9]+\\.el\\)\\>[^.?]" @@ -7731,15 +7757,6 @@ positives are possible." ;; Unlike the other regexps we really have to require quoting ;; here to determine where it ends. 1 (>= gnus-button-emacs-level 1) gnus-button-handle-describe-key 3) - ;; This is how URLs _should_ be embedded in text (RFC 1738, RFC 2396)... - ("<URL: *\\([^\n<>]*\\)>" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; RFC 2396 (2.4.3., delims) ... - ("\"URL: *\\([^\n\"]*\\)\"" - 1 (>= gnus-button-browse-level 0) gnus-button-embedded-url 1) - ;; Raw URLs. - (gnus-button-url-regexp - 0 (>= gnus-button-browse-level 0) browse-url-button-open-url 0) ;; man pages ("\\b\\([a-z][a-z]+([1-9])\\)\\W" 0 (and (>= gnus-button-man-level 1) (< gnus-button-man-level 3)) diff --git a/lisp/gnus/gnus-bookmark.el b/lisp/gnus/gnus-bookmark.el index ea4af2df0c4..1b00bbbc69c 100644 --- a/lisp/gnus/gnus-bookmark.el +++ b/lisp/gnus/gnus-bookmark.el @@ -242,7 +242,7 @@ So the cdr of each bookmark is an alist too.") (save-window-excursion ;; Avoid warnings? ;; (message "Saving Gnus bookmarks to file %s..." gnus-bookmark-default-file) - (set-buffer (get-buffer-create " *Gnus bookmarks*")) + (set-buffer (gnus-get-buffer-create " *Gnus bookmarks*")) (erase-buffer) (gnus-bookmark-insert-file-format-version-stamp) (pp gnus-bookmark-alist (current-buffer)) @@ -357,8 +357,8 @@ deletion, or > if it is flagged for displaying." (interactive) (gnus-bookmark-maybe-load-default-file) (if (called-interactively-p 'any) - (switch-to-buffer (get-buffer-create "*Gnus Bookmark List*")) - (set-buffer (get-buffer-create "*Gnus Bookmark List*"))) + (switch-to-buffer (gnus-get-buffer-create "*Gnus Bookmark List*")) + (set-buffer (gnus-get-buffer-create "*Gnus Bookmark List*"))) (let ((inhibit-read-only t) alist name start end) (erase-buffer) @@ -648,7 +648,7 @@ reposition and try again, else return nil." (details gnus-bookmark-bookmark-details) detail) (save-excursion - (pop-to-buffer (get-buffer-create "*Gnus Bookmark Annotation*") t) + (pop-to-buffer (gnus-get-buffer-create "*Gnus Bookmark Annotation*") t) (erase-buffer) (while details (setq detail (pop details)) diff --git a/lisp/gnus/gnus-cloud.el b/lisp/gnus/gnus-cloud.el index cecfaef2f4f..673a4d22988 100644 --- a/lisp/gnus/gnus-cloud.el +++ b/lisp/gnus/gnus-cloud.el @@ -223,13 +223,10 @@ easy interactive way to set this from the Server buffer." (t (gnus-message 1 "Unknown type %s; ignoring" type)))))) -(defun gnus-cloud-update-newsrc-data (group elem &optional force-older) - "Update the newsrc data for GROUP from ELEM. -Use old data if FORCE-OLDER is not nil." +(defun gnus-cloud-update-newsrc-data (group elem) + "Update the newsrc data for GROUP from ELEM." (let* ((contents (plist-get elem :contents)) (date (or (plist-get elem :timestamp) "0")) - (now (gnus-cloud-timestamp nil)) - (newer (string-lessp date now)) (group-info (gnus-get-info group))) (if (and contents (stringp (nth 0 contents)) @@ -238,15 +235,13 @@ Use old data if FORCE-OLDER is not nil." (if (equal (format "%S" group-info) (format "%S" contents)) (gnus-message 3 "Skipping cloud update of group %s, the info is the same" group) - (if (and newer (not force-older)) - (gnus-message 3 "Skipping outdated cloud info for group %s, the info is from %s (now is %s)" group date now) - (when (or (not gnus-cloud-interactive) - (gnus-y-or-n-p - (format "%s has older different info in the cloud as of %s, update it here? " - group date)))) - (gnus-message 2 "Installing cloud update of group %s" group) - (gnus-set-info group contents) - (gnus-group-update-group group))) + (when (or (not gnus-cloud-interactive) + (gnus-y-or-n-p + (format "%s has different info in the cloud from %s, update it here? " + group date))) + (gnus-message 2 "Installing cloud update of group %s" group) + (gnus-set-info group contents) + (gnus-group-update-group group))) (gnus-error 1 "Sorry, group %s is not subscribed" group)) (gnus-error 1 "Sorry, could not update newsrc for group %s (invalid data %S)" group elem)))) @@ -285,8 +280,8 @@ Use old data if FORCE-OLDER is not nil." (insert new-contents) (when (file-exists-p file-name) (rename-file file-name (car (find-backup-file-name file-name)))) - (write-region (point-min) (point-max) file-name) - (set-file-times file-name (parse-iso8601-time-string date)))) + (write-region (point-min) (point-max) file-name nil nil nil 'excl) + (set-file-times file-name (parse-iso8601-time-string date) 'nofollow))) (defun gnus-cloud-file-covered-p (file-name) (let ((matched nil)) @@ -380,8 +375,9 @@ When FULL is t, upload everything, not just a difference from the last full." (gnus-cloud-files-to-upload full) (gnus-cloud-collect-full-newsrc))) (group (gnus-group-full-name gnus-cloud-group-name gnus-cloud-method))) + (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (insert (format "Subject: (sequence: %s type: %s storage-method: %s)\n" - (or gnus-cloud-sequence "UNKNOWN") + gnus-cloud-sequence (if full :full :partial) gnus-cloud-storage-method)) (insert "From: nobody@gnus.cloud.invalid\n") @@ -390,7 +386,6 @@ When FULL is t, upload everything, not just a difference from the last full." (if (gnus-request-accept-article gnus-cloud-group-name gnus-cloud-method t t) (progn - (setq gnus-cloud-sequence (1+ (or gnus-cloud-sequence 0))) (gnus-cloud-add-timestamps elems) (gnus-message 3 "Uploaded Gnus Cloud data successfully to %s" group) (gnus-group-refresh-group group)) @@ -459,18 +454,21 @@ instead of `gnus-cloud-sequence'. When UPDATE is t, returns the result of calling `gnus-cloud-update-all'. Otherwise, returns the Gnus Cloud data chunks." (let ((articles nil) + (highest-sequence-seen gnus-cloud-sequence) chunks) (dolist (header (gnus-cloud-available-chunks)) - (when (> (gnus-cloud-chunk-sequence (mail-header-subject header)) - (or sequence-override gnus-cloud-sequence -1)) - - (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) - (mail-header-subject header)) - (push (mail-header-number header) articles) - (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" - (mail-header-number header) - gnus-cloud-storage-method - (mail-header-subject header))))) + (let ((this-sequence (gnus-cloud-chunk-sequence (mail-header-subject header)))) + (when (> this-sequence (or sequence-override gnus-cloud-sequence -1)) + + (if (string-match (format "storage-method: %s" gnus-cloud-storage-method) + (mail-header-subject header)) + (progn + (push (mail-header-number header) articles) + (setq highest-sequence-seen (max highest-sequence-seen this-sequence))) + (gnus-message 1 "Skipping article %s because it didn't match the Gnus Cloud method %s: %s" + (mail-header-number header) + gnus-cloud-storage-method + (mail-header-subject header)))))) (when articles (nnimap-request-articles (nreverse articles) gnus-cloud-group-name) (with-current-buffer nntp-server-buffer @@ -480,7 +478,8 @@ Otherwise, returns the Gnus Cloud data chunks." (push (gnus-cloud-parse-chunk) chunks) (forward-line 1)))) (if update - (mapcar #'gnus-cloud-update-all chunks) + (prog1 (mapcar #'gnus-cloud-update-all chunks) + (setq gnus-cloud-sequence highest-sequence-seen)) chunks))) (defun gnus-cloud-server-p (server) diff --git a/lisp/gnus/gnus-delay.el b/lisp/gnus/gnus-delay.el index 8dae4ef5c17..63e938e7453 100644 --- a/lisp/gnus/gnus-delay.el +++ b/lisp/gnus/gnus-delay.el @@ -75,7 +75,11 @@ DELAY is a string, giving the length of the time. Possible values are: variable `gnus-delay-default-hour', minute and second are zero. * hh:mm for a specific time. Use 24h format. If it is later than this - time, then the deadline is tomorrow, else today." + time, then the deadline is tomorrow, else today. + +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent." (interactive (list (read-string "Target date (YYYY-MM-DD), time (hh:mm), or length of delay (units in [mhdwMY]): " diff --git a/lisp/gnus/gnus-draft.el b/lisp/gnus/gnus-draft.el index 1b25d247389..3a9bf2a7e8f 100644 --- a/lisp/gnus/gnus-draft.el +++ b/lisp/gnus/gnus-draft.el @@ -248,7 +248,7 @@ If DONT-POP is nil, display the buffer after setting it up." (let ((article narticle)) (message-mail nil nil nil nil (if dont-pop - (lambda (buf) (set-buffer (get-buffer-create buf))))) + (lambda (buf) (set-buffer (gnus-get-buffer-create buf))))) (let ((inhibit-read-only t)) (erase-buffer)) (if (not (gnus-request-restore-buffer article group)) diff --git a/lisp/gnus/gnus-eform.el b/lisp/gnus/gnus-eform.el index 54118aad1e6..1bc1261ee8f 100644 --- a/lisp/gnus/gnus-eform.el +++ b/lisp/gnus/gnus-eform.el @@ -50,13 +50,13 @@ (defvar gnus-edit-form-buffer "*Gnus edit form*") (defvar gnus-edit-form-done-function nil) -(defvar gnus-edit-form-mode-map nil) -(unless gnus-edit-form-mode-map - (setq gnus-edit-form-mode-map (make-sparse-keymap)) - (set-keymap-parent gnus-edit-form-mode-map emacs-lisp-mode-map) - (gnus-define-keys gnus-edit-form-mode-map - "\C-c\C-c" gnus-edit-form-done - "\C-c\C-k" gnus-edit-form-exit)) +(defvar gnus-edit-form-mode-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map emacs-lisp-mode-map) + (gnus-define-keys map + "\C-c\C-c" gnus-edit-form-done + "\C-c\C-k" gnus-edit-form-exit) + map)) (defun gnus-edit-form-make-menu-bar () (unless (boundp 'gnus-edit-form-menu) @@ -67,9 +67,9 @@ ["Exit" gnus-edit-form-exit t])) (gnus-run-hooks 'gnus-edit-form-menu-hook))) -(define-derived-mode gnus-edit-form-mode fundamental-mode "Edit Form" +(define-derived-mode gnus-edit-form-mode lisp-data-mode "Edit Form" "Major mode for editing forms. -It is a slightly enhanced emacs-lisp-mode. +It is a slightly enhanced `lisp-data-mode'. \\{gnus-edit-form-mode-map}" (when (gnus-visual-p 'group-menu 'menu) diff --git a/lisp/gnus/gnus-fun.el b/lisp/gnus/gnus-fun.el index 33cbf4a54a9..c95449762e4 100644 --- a/lisp/gnus/gnus-fun.el +++ b/lisp/gnus/gnus-fun.el @@ -40,7 +40,7 @@ "Regexp to match faces in `gnus-x-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-face-directory (expand-file-name "faces" gnus-directory) "Directory where Face PNG files are stored." @@ -52,7 +52,7 @@ "Regexp to match faces in `gnus-face-directory' to be omitted." :version "25.1" :group 'gnus-fun - :type '(choice (const nil) string)) + :type '(choice (const nil) regexp)) (defcustom gnus-convert-pbm-to-x-face-command "pbmtoxbm %s | compface" "Command for converting a PBM to an X-Face." diff --git a/lisp/gnus/gnus-group.el b/lisp/gnus/gnus-group.el index b89f040b435..97e10a37a21 100644 --- a/lisp/gnus/gnus-group.el +++ b/lisp/gnus/gnus-group.el @@ -1129,8 +1129,8 @@ The following commands are available: (gnus-update-group-mark-positions) (when gnus-use-undo (gnus-undo-mode 1)) - (when gnus-slave - (gnus-slave-mode))) + (when gnus-child + (gnus-child-mode))) (defun gnus-update-group-mark-positions () (save-excursion @@ -1768,7 +1768,7 @@ already. If INFO-UNCHANGED is non-nil, dribble buffer is not updated." (get-text-property (point-at-bol) 'gnus-unread)) (defun gnus-group-new-mail (group) - (if (nnmail-new-mail-p (gnus-group-real-name group)) + (if (nnmail-new-mail-p group) gnus-new-mail-mark ?\s)) @@ -3600,7 +3600,7 @@ or nil if no action could be taken." (marks (gnus-info-marks (nth 1 entry))) (unread (gnus-sequence-of-unread-articles group))) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Do the updating only if the newsgroup isn't killed. (if (not (numberp (car entry))) (gnus-message 1 "Can't catch up %s; non-active group" group) @@ -3761,10 +3761,10 @@ group line." (newsrc ;; Toggle subscription flag. (gnus-group-change-level - newsrc (if level level (if (<= (gnus-info-level (nth 1 newsrc)) - gnus-level-subscribed) - (1+ gnus-level-subscribed) - gnus-level-default-subscribed))) + newsrc (or level (if (<= (gnus-info-level (nth 1 newsrc)) + gnus-level-subscribed) + (1+ gnus-level-subscribed) + gnus-level-default-subscribed))) (unless silent (gnus-group-update-group group))) ((and (stringp group) @@ -3773,7 +3773,7 @@ group line." ;; Add new newsgroup. (gnus-group-change-level group - (if level level gnus-level-default-subscribed) + (or level gnus-level-default-subscribed) (or (and (member group gnus-zombie-list) gnus-level-zombie) gnus-level-killed) @@ -4024,9 +4024,9 @@ otherwise all levels below ARG will be scanned too." (gnus-run-hooks 'gnus-get-top-new-news-hook) (gnus-run-hooks 'gnus-get-new-news-hook) - ;; Read any slave files. - (unless gnus-slave - (gnus-master-read-slave-newsrc)) + ;; Read any child files. + (unless gnus-child + (gnus-parent-read-child-newsrc)) (gnus-get-unread-articles (gnus-group-default-level arg t) nil one-level) diff --git a/lisp/gnus/gnus-icalendar.el b/lisp/gnus/gnus-icalendar.el index ee556a32080..305e17fd8fc 100644 --- a/lisp/gnus/gnus-icalendar.el +++ b/lisp/gnus/gnus-icalendar.el @@ -814,7 +814,7 @@ These will be used to retrieve the RSVP information from ical events." (let ((subject (concat (capitalize (symbol-name status)) ": " (gnus-icalendar-event:summary event)))) - (with-current-buffer (get-buffer-create gnus-icalendar-reply-bufname) + (with-current-buffer (gnus-get-buffer-create gnus-icalendar-reply-bufname) (delete-region (point-min) (point-max)) (insert reply) (fold-icalendar-buffer) diff --git a/lisp/gnus/gnus-int.el b/lisp/gnus/gnus-int.el index c304f575d92..60ebc07c343 100644 --- a/lisp/gnus/gnus-int.el +++ b/lisp/gnus/gnus-int.el @@ -253,7 +253,7 @@ If it is down, start it up (again)." (defun gnus-backend-trace (type form) (when gnus-backend-trace - (with-current-buffer (get-buffer-create "*gnus trace*") + (with-current-buffer (gnus-get-buffer-create "*gnus trace*") (buffer-disable-undo) (goto-char (point-max)) (insert (format-time-string "%H:%M:%S") diff --git a/lisp/gnus/gnus-kill.el b/lisp/gnus/gnus-kill.el index 5edbaaf201b..a772281d4c3 100644 --- a/lisp/gnus/gnus-kill.el +++ b/lisp/gnus/gnus-kill.el @@ -653,7 +653,7 @@ Usage: emacs -batch -l ~/.emacs -l gnus -f gnus-batch-score" gnus-options-not-subscribe) ;; Eat all arguments. (setq command-line-args-left nil) - (gnus-slave) + (gnus-child) ;; Apply kills to specified newsgroups in command line arguments. (setq newsrc (cdr gnus-newsrc-alist)) (while (setq info (pop newsrc)) diff --git a/lisp/gnus/gnus-msg.el b/lisp/gnus/gnus-msg.el index daaea3980b5..cdfbf16db5e 100644 --- a/lisp/gnus/gnus-msg.el +++ b/lisp/gnus/gnus-msg.el @@ -1510,7 +1510,11 @@ If YANK is non-nil, include the original article." (gnus-inews-yank-articles (list (cdr gnus-article-current))))))) (defun gnus-bug (subject) - "Send a bug report to the Emacs maintainers." + "Send a bug report to the Emacs maintainers. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (interactive "sBug Subject: ") (report-emacs-bug subject) (save-excursion diff --git a/lisp/gnus/gnus-registry.el b/lisp/gnus/gnus-registry.el index fd2b44f7424..1ac1d05e033 100644 --- a/lisp/gnus/gnus-registry.el +++ b/lisp/gnus/gnus-registry.el @@ -1,4 +1,4 @@ -;;; gnus-registry.el --- article registry for Gnus +;;; gnus-registry.el --- article registry for Gnus -*- lexical-binding: t; -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -62,10 +62,10 @@ ;; show the marks as single characters (see the :char property in ;; `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) ;; show the marks by name (see `gnus-registry-marks'): -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) ;; TODO: @@ -449,19 +449,21 @@ This is not required after changing `gnus-registry-cache-file'." to subject sender recipients))) (defun gnus-registry-spool-action (id group &optional subject sender recipients) - (let ((to (gnus-group-guess-full-name-from-command-method group)) - (recipients (or recipients - (gnus-registry-sort-addresses - (or (message-fetch-field "cc") "") - (or (message-fetch-field "to") "")))) - (subject (or subject (message-fetch-field "subject"))) - (sender (or sender (message-fetch-field "from")))) - (when (and (stringp id) (string-match "\r$" id)) - (setq id (substring id 0 -1))) - (gnus-message 7 "Gnus registry: article %s spooled to %s" - id - to) - (gnus-registry-handle-action id nil to subject sender recipients))) + (save-restriction + (message-narrow-to-headers-or-head) + (let ((to (gnus-group-guess-full-name-from-command-method group)) + (recipients (or recipients + (gnus-registry-sort-addresses + (or (message-fetch-field "cc") "") + (or (message-fetch-field "to") "")))) + (subject (or subject (message-fetch-field "subject"))) + (sender (or sender (message-fetch-field "from")))) + (when (and (stringp id) (string-match "\r$" id)) + (setq id (substring id 0 -1))) + (gnus-message 7 "Gnus registry: article %s spooled to %s" + id + to) + (gnus-registry-handle-action id nil to subject sender recipients)))) (defun gnus-registry-handle-action (id from to subject sender &optional recipients) @@ -485,23 +487,25 @@ This is not required after changing `gnus-registry-cache-file'." (when from (setq entry (cons (delete from (assoc 'group entry)) (assq-delete-all 'group entry)))) - - (dolist (kv `((group ,to) - (sender ,sender) - (recipient ,@recipients) - (subject ,subject))) - (when (cadr kv) - (let ((new (or (assq (car kv) entry) - (list (car kv))))) - (dolist (toadd (cdr kv)) - (unless (member toadd new) - (setq new (append new (list toadd))))) - (setq entry (cons new - (assq-delete-all (car kv) entry)))))) - (gnus-message 10 "Gnus registry: new entry for %s is %S" - id - entry) - (gnus-registry-insert db id entry))) + ;; Only keep the entry if the message is going to a new group, or + ;; it's still in some previous group. + (when (or to (alist-get 'group entry)) + (dolist (kv `((group ,to) + (sender ,sender) + (recipient ,@recipients) + (subject ,subject))) + (when (cadr kv) + (let ((new (or (assq (car kv) entry) + (list (car kv))))) + (dolist (toadd (cdr kv)) + (unless (member toadd new) + (setq new (append new (list toadd))))) + (setq entry (cons new + (assq-delete-all (car kv) entry)))))) + (gnus-message 10 "Gnus registry: new entry for %s is %S" + id + entry) + (gnus-registry-insert db id entry)))) ;; Function for nn{mail|imap}-split-fancy: look up all references in ;; the cache and if a match is found, return that group. @@ -588,7 +592,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." subject (< gnus-registry-minimum-subject-length (length subject))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -615,7 +619,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." sender gnus-registry-unfollowed-addresses))) (let ((groups (apply - 'append + #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -644,7 +648,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (not (gnus-grep-in-list recp gnus-registry-unfollowed-addresses))) - (let ((groups (apply 'append + (let ((groups (apply #'append (mapcar (lambda (reference) (gnus-registry-get-id-key reference 'group)) @@ -663,7 +667,7 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." ;; filter the found groups and return them ;; the found groups are NOT the full groups (setq found (gnus-registry-post-process-groups - "recipients" (mapconcat 'identity recipients ", ") found))) + "recipients" (mapconcat #'identity recipients ", ") found))) ;; after the (cond) we extract the actual value safely (car-safe found))) @@ -791,7 +795,8 @@ Consults `gnus-registry-ignored-groups' and ((stringp g) g) ((and (listp g) (nth 1 g)) (nth 0 g)) - (t nil))) gnus-registry-ignored-groups))) + (t nil))) + gnus-registry-ignored-groups))) ;; only use `gnus-parameter-registry-ignore' if ;; `gnus-registry-ignored-groups' is a list of lists ;; (it can be a list of regexes) @@ -871,7 +876,7 @@ Addresses without a name will say \"noname\"." (defun gnus-registry-sort-addresses (&rest addresses) "Return a normalized and sorted list of ADDRESSES." - (sort (mapcan 'gnus-registry-extract-addresses addresses) 'string-lessp)) + (sort (mapcan #'gnus-registry-extract-addresses addresses) 'string-lessp)) (defun gnus-registry-simplify-subject (subject) (if (stringp subject) @@ -961,16 +966,15 @@ Uses `gnus-registry-marks' to find what shortcuts to install." (intern (format function-format variant-name))) (shortcut (format "%c" (if remove (upcase data) data)))) (defalias function-name - ;; If it weren't for the function's docstring, we could - ;; use a closure, with lexical-let :-( - `(lambda (&rest articles) - ,(format - "%s the %s mark over process-marked ARTICLES." - (upcase-initials variant-name) - mark) - (interactive - (gnus-summary-work-articles current-prefix-arg)) - (gnus-registry--set/remove-mark ',mark ',remove articles))) + (lambda (&rest articles) + (:documentation + (format + "%s the %s mark over process-marked ARTICLES." + (upcase-initials variant-name) + mark)) + (interactive + (gnus-summary-work-articles current-prefix-arg)) + (gnus-registry--set/remove-mark mark remove articles))) (push function-name keys-plist) (push shortcut keys-plist) (push (vector (format "%s %s" @@ -990,14 +994,11 @@ Uses `gnus-registry-marks' to find what shortcuts to install." nil (cons "Registry Marks" gnus-registry-misc-menus)))))) -(make-obsolete 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars "24.1") ? - -(defalias 'gnus-registry-user-format-function-M - 'gnus-registry-article-marks-to-chars) +(define-obsolete-function-alias 'gnus-registry-user-format-function-M + #'gnus-registry-article-marks-to-chars "24.1") ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-chars) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-chars) (defun gnus-registry-article-marks-to-chars (headers) "Show the marks for an article by the :char property." (if gnus-registry-enabled @@ -1013,20 +1014,20 @@ Uses `gnus-registry-marks' to find what shortcuts to install." "")) ;; use like this: -;; (defalias 'gnus-user-format-function-M 'gnus-registry-article-marks-to-names) +;; (defalias 'gnus-user-format-function-M #'gnus-registry-article-marks-to-names) (defun gnus-registry-article-marks-to-names (headers) "Show the marks for an article by name." (if gnus-registry-enabled (let* ((id (mail-header-message-id headers)) (marks (when id (gnus-registry-get-id-key id 'mark)))) - (mapconcat (lambda (mark) (symbol-name mark)) marks ",")) + (mapconcat #'symbol-name marks ",")) "")) (defun gnus-registry-read-mark () "Read a mark name from the user with completion." (let ((mark (gnus-completing-read "Label" - (mapcar 'symbol-name (mapcar 'car gnus-registry-marks)) + (mapcar #'symbol-name (mapcar #'car gnus-registry-marks)) nil nil nil (symbol-name gnus-registry-default-mark)))) (when (stringp mark) @@ -1050,7 +1051,7 @@ Uses `gnus-registry-marks' to find what shortcuts to install." show-message) "Apply or remove MARK across a list of ARTICLES." (let ((article-id-list - (mapcar 'gnus-registry-fetch-message-id-fast articles))) + (mapcar #'gnus-registry-fetch-message-id-fast articles))) (dolist (id article-id-list) (let* ((marks (delq mark (gnus-registry-get-id-key id 'mark))) (marks (if remove marks (cons mark marks)))) @@ -1173,34 +1174,34 @@ only the last one's marks are returned." (gnus-registry-install-shortcuts) (if (gnus-alive-p) (gnus-registry-load) - (add-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load))) + (add-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load))) (defun gnus-registry-install-hooks () "Install the registry hooks." (setq gnus-registry-enabled t) - (add-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (add-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (add-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (add-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (add-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (add-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (add-hook 'gnus-save-newsrc-hook 'gnus-registry-save) + (add-hook 'gnus-save-newsrc-hook #'gnus-registry-save) - (add-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids)) + (add-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids)) (defun gnus-registry-unload-hook () "Uninstall the registry hooks." - (remove-hook 'gnus-summary-article-move-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-delete-hook 'gnus-registry-action) - (remove-hook 'gnus-summary-article-expire-hook 'gnus-registry-action) - (remove-hook 'nnmail-spool-hook 'gnus-registry-spool-action) + (remove-hook 'gnus-summary-article-move-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-delete-hook #'gnus-registry-action) + (remove-hook 'gnus-summary-article-expire-hook #'gnus-registry-action) + (remove-hook 'nnmail-spool-hook #'gnus-registry-spool-action) - (remove-hook 'gnus-save-newsrc-hook 'gnus-registry-save) - (remove-hook 'gnus-read-newsrc-el-hook 'gnus-registry-load) + (remove-hook 'gnus-save-newsrc-hook #'gnus-registry-save) + (remove-hook 'gnus-read-newsrc-el-hook #'gnus-registry-load) - (remove-hook 'gnus-summary-prepare-hook 'gnus-registry-register-message-ids) + (remove-hook 'gnus-summary-prepare-hook #'gnus-registry-register-message-ids) (setq gnus-registry-enabled nil)) -(add-hook 'gnus-registry-unload-hook 'gnus-registry-unload-hook) +(add-hook 'gnus-registry-unload-hook #'gnus-registry-unload-hook) (defun gnus-registry-install-p () "Return non-nil if the registry is enabled (and maybe enable it first). @@ -1234,7 +1235,7 @@ data stored in the registry." (seen-groups (list (gnus-group-group-name)))) (catch 'found - (dolist (group (mapcar 'gnus-simplify-group-name groups)) + (dolist (group (mapcar #'gnus-simplify-group-name groups)) ;; skip over any groups we really don't want to warp to. (unless (or (member group seen-groups) @@ -1270,7 +1271,7 @@ EXTRA is a list of symbols. Valid symbols are those contained in the docs of `gnus-registry-track-extra'. This command is useful when you stop tracking some extra data and now want to purge it from your existing entries." - (interactive (list (mapcar 'intern + (interactive (list (mapcar #'intern (completing-read-multiple "Extra data: " '("subject" "sender" "recipient"))))) diff --git a/lisp/gnus/gnus-sieve.el b/lisp/gnus/gnus-sieve.el index 278e3a5d6f3..5d8f9b55deb 100644 --- a/lisp/gnus/gnus-sieve.el +++ b/lisp/gnus/gnus-sieve.el @@ -29,8 +29,6 @@ (require 'gnus) (require 'gnus-sum) -(require 'format-spec) -(autoload 'sieve-mode "sieve-mode") (eval-when-compile (require 'sieve)) @@ -88,10 +86,10 @@ See the documentation for these variables and functions for details." (save-buffer) (shell-command (format-spec gnus-sieve-update-shell-command - (format-spec-make ?f gnus-sieve-file - ?s (or (cadr (gnus-server-get-method - nil gnus-sieve-select-method)) - ""))))) + `((?f . ,gnus-sieve-file) + (?s . ,(or (cadr (gnus-server-get-method + nil gnus-sieve-select-method)) + "")))))) ;;;###autoload (defun gnus-sieve-generate () diff --git a/lisp/gnus/gnus-srvr.el b/lisp/gnus/gnus-srvr.el index d58bd7a73b5..095e05408d6 100644 --- a/lisp/gnus/gnus-srvr.el +++ b/lisp/gnus/gnus-srvr.el @@ -309,7 +309,7 @@ The following commands are available: ;; `gnus-server-buffer' selected as the current buffer, but not always (I ;; bumped into it when starting from a dedicated *Group* frame, and ;; gnus-configure-windows opened *Server* into its own dedicated frame). - (with-current-buffer (get-buffer-create gnus-server-buffer) + (with-current-buffer (gnus-get-buffer-create gnus-server-buffer) (gnus-server-mode) (gnus-server-prepare))) diff --git a/lisp/gnus/gnus-start.el b/lisp/gnus/gnus-start.el index 61319266ced..ba8b91be5c5 100644 --- a/lisp/gnus/gnus-start.el +++ b/lisp/gnus/gnus-start.el @@ -730,7 +730,7 @@ the first newsgroup." ;; Remove Gnus frames. (gnus-kill-gnus-frames)) -(defun gnus-no-server-1 (&optional arg slave) +(defun gnus-no-server-1 (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2 @@ -739,11 +739,11 @@ and not a positive number, Gnus will prompt the user for the name of an NNTP server to use. As opposed to \\[gnus], this command will not connect to the local server." (let ((val (or arg (1- gnus-level-default-subscribed)))) - (gnus val t slave) + (gnus val t child) (make-local-variable 'gnus-group-use-permanent-levels) (setq gnus-group-use-permanent-levels val))) -(defun gnus-1 (&optional arg dont-connect slave) +(defun gnus-1 (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -761,7 +761,7 @@ prompt the user for the name of an NNTP server to use." (gnus-splash) (gnus-run-hooks 'gnus-before-startup-hook) (nnheader-init-server-buffer) - (setq gnus-slave slave) + (setq gnus-child child) (gnus-read-init-file) ;; Add "native" to gnus-predefined-server-alist just to have a @@ -790,7 +790,7 @@ prompt the user for the name of an NNTP server to use." (gnus-make-newsrc-file gnus-startup-file)) ;; Read the dribble file. - (when (or gnus-slave gnus-use-dribble-file) + (when (or gnus-child gnus-use-dribble-file) (gnus-dribble-read-file)) ;; Do the actual startup. @@ -1008,11 +1008,11 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Possibly eval the dribble file. (and init - (or gnus-use-dribble-file gnus-slave) + (or gnus-use-dribble-file gnus-child) (gnus-dribble-eval-file)) - ;; Slave Gnusii should then clear the dribble buffer. - (when (and init gnus-slave) + ;; Child Gnusii should then clear the dribble buffer. + (when (and init gnus-child) (gnus-dribble-clear)) (gnus-update-format-specifications) @@ -1030,7 +1030,7 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." ;; Find new newsgroups and treat them. (when (and init gnus-check-new-newsgroups (not level) (gnus-check-server gnus-select-method) - (not gnus-slave) + (not gnus-child) gnus-plugged) (gnus-find-new-newsgroups)) @@ -1040,8 +1040,8 @@ If LEVEL is non-nil, the news will be set up at level LEVEL." (gnus-server-opened gnus-select-method)) (gnus-check-bogus-newsgroups)) - ;; Read any slave files. - (gnus-master-read-slave-newsrc) + ;; Read any child files. + (gnus-parent-read-child-newsrc) ;; Find the number of unread articles in each non-dead group. (let ((gnus-read-active-file (and (not level) gnus-read-active-file))) @@ -1256,19 +1256,19 @@ INFO-LIST), otherwise it's a list in the format of the `gnus-newsrc-hashtb' entries. LEVEL is the new level of the group, OLDLEVEL is the old level and PREVIOUS is the group (a string name) to insert this group before." - (let (group info active num) - ;; Glean what info we can from the arguments. - (if (consp entry) - (setq group (if fromkilled (nth 1 entry) (car (nth 1 entry)))) - (setq group entry)) + ;; Glean what info we can from the arguments. + (let ((group (if (consp entry) + (if fromkilled (nth 1 entry) (car (nth 1 entry))) + entry)) + info active num) (when (and (stringp entry) oldlevel (< oldlevel gnus-level-zombie)) (setq entry (gnus-group-entry entry))) - (if (and (not oldlevel) - (consp entry)) - (setq oldlevel (gnus-info-level (nth 1 entry))) - (setq oldlevel (or oldlevel gnus-level-killed))) + (setq oldlevel (if (and (not oldlevel) + (consp entry)) + (gnus-info-level (nth 1 entry)) + (or oldlevel gnus-level-killed))) ;; This table is used for completion, so put a dummy entry there. (unless (gethash group gnus-active-hashtb) @@ -2111,6 +2111,7 @@ The info element is shared with the same element of ((string= gnus-ignored-newsgroups "") (delete-matching-lines "^to\\.")) (t + ;; relint suppression: Duplicated alternative branch (delete-matching-lines (concat "^to\\.\\|" gnus-ignored-newsgroups)))) (goto-char (point-min)) @@ -2737,15 +2738,15 @@ values from `gnus-newsrc-hashtb', and write a new value of (gnus-agent-save-local force)) (save-excursion - (if (and (or gnus-use-dribble-file gnus-slave) + (if (and (or gnus-use-dribble-file gnus-child) (not force) (or (not (buffer-live-p gnus-dribble-buffer)) (zerop (with-current-buffer gnus-dribble-buffer (buffer-size))))) (gnus-message 4 "(No changes need to be saved)") (gnus-run-hooks 'gnus-save-newsrc-hook) - (if gnus-slave - (gnus-slave-save-newsrc) + (if gnus-child + (gnus-child-save-newsrc) ;; Save .newsrc only if the select method is an NNTP method. ;; The .newsrc file is for interoperability with other ;; newsreaders, so saving non-NNTP groups there doesn't make @@ -2812,7 +2813,7 @@ values from `gnus-newsrc-hashtb', and write a new value of (file-exists-p working-file))) (unwind-protect - (progn + (with-file-modes (file-modes startup-file) (gnus-with-output-to-file working-file (gnus-gnus-to-quick-newsrc-format) (gnus-run-hooks 'gnus-save-quick-newsrc-hook)) @@ -2822,14 +2823,12 @@ values from `gnus-newsrc-hashtb', and write a new value of ;; file. (let ((buffer-backed-up nil) (buffer-file-name startup-file) - (file-precious-flag t) - (setmodes (file-modes startup-file))) + (file-precious-flag t)) ;; Backup the current version of the startup file. (backup-buffer) ;; Replace the existing startup file with the temp file. (rename-file working-file startup-file t) - (gnus-set-file-modes startup-file setmodes) (setq gnus-save-newsrc-file-last-timestamp (file-attribute-modification-time (file-attributes startup-file))))) @@ -2990,55 +2989,61 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." ;;; -;;; Slave functions. +;;; Child functions. ;;; -(defvar gnus-slave-mode nil) +(defvar gnus-child-mode nil) -(defun gnus-slave-mode () - "Minor mode for slave Gnusae." - ;; FIXME: gnus-slave-mode appears to never be set (i.e. it'll always be nil): +(defun gnus-child-mode () + "Minor mode for child Gnusae." + ;; FIXME: gnus-child-mode appears to never be set (i.e. it'll always be nil): ;; Remove, or fix and use define-minor-mode. - (add-minor-mode 'gnus-slave-mode " Slave" (make-sparse-keymap)) - (gnus-run-hooks 'gnus-slave-mode-hook)) + (add-minor-mode 'gnus-child-mode " Child" (make-sparse-keymap)) + (gnus-run-hooks 'gnus-child-mode-hook)) -(defun gnus-slave-save-newsrc () +(define-obsolete-function-alias 'gnus-slave-mode #'gnus-child-mode "28.1") +(define-obsolete-variable-alias 'gnus-slave-mode-hook 'gnus-child-mode-hook + "28.1") + +(defun gnus-child-save-newsrc () (with-current-buffer gnus-dribble-buffer - (let ((slave-name - (make-temp-file (concat gnus-current-startup-file "-slave-"))) - (modes (ignore-errors - (file-modes (concat gnus-current-startup-file ".eld"))))) - (let ((coding-system-for-write gnus-ding-file-coding-system)) - (gnus-write-buffer slave-name)) - (when modes - (gnus-set-file-modes slave-name modes))))) - -(defun gnus-master-read-slave-newsrc () - (let ((slave-files + (with-file-modes (or (ignore-errors + (file-modes + (concat gnus-current-startup-file ".eld"))) + (default-file-modes)) + (let ((child-name + (make-temp-file (concat gnus-current-startup-file "-child-")))) + (let ((coding-system-for-write gnus-ding-file-coding-system)) + (gnus-write-buffer child-name)))))) + +(defun gnus-parent-read-child-newsrc () + (let ((child-files (directory-files (file-name-directory gnus-current-startup-file) t (concat "^" (regexp-quote - (concat - (file-name-nondirectory gnus-current-startup-file) - "-slave-"))) + (file-name-nondirectory gnus-current-startup-file)) + ;; When the obsolete variables like + ;; `gnus-slave-mode-hook' etc are removed, the "slave" + ;; bit of this regexp should also be removed. + "\\(-child-\\|-slave-\\)") t)) file) - (if (not slave-files) - () ; There are no slave files to read. - (gnus-message 7 "Reading slave newsrcs...") - (with-current-buffer (gnus-get-buffer-create " *gnus slave*") - (setq slave-files + (if (not child-files) + () ; There are no child files to read. + (gnus-message 7 "Reading child newsrcs...") + (with-current-buffer (gnus-get-buffer-create " *gnus child*") + (setq child-files (sort (mapcar (lambda (file) (list (file-attribute-modification-time (file-attributes file)) file)) - slave-files) + child-files) (lambda (f1 f2) (time-less-p (car f1) (car f2))))) - (while slave-files + (while child-files (erase-buffer) - (setq file (nth 1 (car slave-files))) + (setq file (nth 1 (car child-files))) (nnheader-insert-file-contents file) (when (condition-case () (progn @@ -3047,12 +3052,12 @@ SPECIFIC-VARIABLES, or those in `gnus-variable-list'." (error (gnus-error 3.2 "Possible error in %s" file) nil)) - (unless gnus-slave ; Slaves shouldn't delete these files. + (unless gnus-child ; Children shouldn't delete these files. (ignore-errors (delete-file file)))) - (setq slave-files (cdr slave-files)))) + (setq child-files (cdr child-files)))) (gnus-dribble-touch) - (gnus-message 7 "Reading slave newsrcs...done")))) + (gnus-message 7 "Reading child newsrcs...done")))) ;;; diff --git a/lisp/gnus/gnus-sum.el b/lisp/gnus/gnus-sum.el index 9b11d5878d9..c1216a0cc24 100644 --- a/lisp/gnus/gnus-sum.el +++ b/lisp/gnus/gnus-sum.el @@ -1501,9 +1501,9 @@ the type of the variable (string, integer, character, etc).") ;; This is here rather than in gnus-art for compilation reasons. (defvar gnus-article-mode-line-format-alist - (nconc '((?w (gnus-article-wash-status) ?s) - (?m (gnus-article-mime-part-status) ?s)) - gnus-summary-mode-line-format-alist)) + (append '((?w (gnus-article-wash-status) ?s) + (?m (gnus-article-mime-part-status) ?s)) + gnus-summary-mode-line-format-alist)) (defvar gnus-last-search-regexp nil "Default regexp for article search command.") @@ -5352,7 +5352,8 @@ or a straight list of headers." ;; We remember that we probably want to output a dummy ;; root. (setq gnus-tmp-dummy-line gnus-tmp-header) - (setq gnus-tmp-prev-subject gnus-tmp-header)) + (setq gnus-tmp-prev-subject + (gnus-simplify-subject-fully gnus-tmp-header))) (t ;; We do not make a root for the gathered ;; sub-threads at all. @@ -7310,7 +7311,7 @@ If FORCE (the prefix), also save the .newsrc file(s)." (when gnus-use-cache (gnus-cache-write-active)) ;; Remove entries for this group. - (nnmail-purge-split-history (gnus-group-real-name group)) + (nnmail-purge-split-history group) ;; Make all changes in this group permanent. (unless quit-config (gnus-run-hooks 'gnus-exit-group-hook) @@ -7331,6 +7332,8 @@ If FORCE (the prefix), also save the .newsrc file(s)." (gnus-group-next-unread-group 1)) (setq group-point (point)) (gnus-article-stop-animations) + (unless leave-hidden + (gnus-configure-windows 'group 'force)) (if temporary nil ;Nothing to do. (set-buffer buf) @@ -7350,8 +7353,6 @@ If FORCE (the prefix), also save the .newsrc file(s)." (if quit-config (gnus-handle-ephemeral-exit quit-config) (goto-char group-point) - (unless leave-hidden - (gnus-configure-windows 'group 'force)) ;; If gnus-group-buffer is already displayed, make sure we also move ;; the cursor in the window that displays it. (let ((win (get-buffer-window (current-buffer) 0))) @@ -9493,16 +9494,6 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (push primary urls)) (delete-dups urls))) -;; cf. `ediff-truncate-string-left', to become `string-truncate-left' -;; in Emacs 28 -(defun gnus--string-truncate-left (string length) - "Truncate STRING to LENGTH, replacing initial surplus with \"...\"." - (let ((strlen (length string))) - (if (<= strlen length) - string - (setq length (max 0 (- length 3))) - (concat "..." (substring string (max 0 (- strlen 1 length))))))) - (defun gnus-shorten-url (url max) "Return an excerpt from URL not exceeding MAX characters." (if (<= (length url) max) @@ -9512,7 +9503,7 @@ The 1st element is the button named by `gnus-collect-urls-primary-text'." (rest (concat (url-filename parsed) (when-let ((target (url-target parsed))) (concat "#" target))))) - (concat host (gnus--string-truncate-left rest (- max (length host))))))) + (concat host (string-truncate-left rest (- max (length host))))))) (defun gnus-summary-browse-url (&optional external) "Scan the current article body for links, and offer to browse them. @@ -12320,7 +12311,7 @@ no matter what the properties `:decode' and `:headers' are." (buffer-string)))))) (put 'gnus-summary-save-in-pipe :headers headers)) (unless (zerop (length result)) - (if (with-current-buffer (get-buffer-create result-buffer) + (if (with-current-buffer (gnus-get-buffer-create result-buffer) (erase-buffer) (insert result) (prog1 @@ -12508,7 +12499,7 @@ save those articles instead." (gnus-activate-group to-newsgroup nil nil to-method) (gnus-subscribe-group to-newsgroup)) (error "Couldn't create group %s" to-newsgroup))) - (error "No such group: %s" to-newsgroup)) + (user-error "No such group: %s" to-newsgroup)) to-newsgroup))) (defvar gnus-summary-save-parts-counter) @@ -12518,10 +12509,15 @@ save those articles instead." "Save parts matching TYPE to DIR. If REVERSE, save parts that do not match TYPE." (interactive - (list (read-string "Save parts of type: " - (or (car gnus-summary-save-parts-type-history) - gnus-summary-save-parts-default-mime) - 'gnus-summary-save-parts-type-history) + (list (completing-read "Save parts of type: " + (progn + (gnus-summary-select-article nil t) + (gnus-eval-in-buffer-window gnus-article-buffer + (delete-dups + (mapcar (lambda (h) + (mm-handle-media-type (cdr h))) + gnus-article-mime-handle-alist)))) + nil nil nil 'gnus-summary-save-parts-type-history) (setq gnus-summary-save-parts-last-directory (read-directory-name "Save to directory: " gnus-summary-save-parts-last-directory diff --git a/lisp/gnus/gnus-util.el b/lisp/gnus/gnus-util.el index 3429d6560b7..8d8956f1fb9 100644 --- a/lisp/gnus/gnus-util.el +++ b/lisp/gnus/gnus-util.el @@ -768,7 +768,7 @@ nil. See also `gnus-bind-print-variables'." If there's no subdirectory, delete DIRECTORY as well." (when (file-directory-p directory) (let ((files (directory-files - directory t (rx (or (not ".") "...")))) + directory t directory-files-no-dot-files-regexp)) file dir) (while files (setq file (pop files)) @@ -950,7 +950,7 @@ FILENAME exists and is Babyl format." (setq rmail-default-rmail-file filename) ; 22 (setq rmail-default-file filename)) ; 23 (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*")) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*")) ;; Babyl rmail.el defines this, mbox does not. (babyl (fboundp 'rmail-insert-rmail-file-header))) (save-excursion @@ -1036,7 +1036,7 @@ FILENAME exists and is Babyl format." (require 'nnmail) (setq filename (expand-file-name filename)) (let ((artbuf (current-buffer)) - (tmpbuf (get-buffer-create " *Gnus-output*"))) + (tmpbuf (gnus-get-buffer-create " *Gnus-output*"))) (save-excursion ;; Create the file, if it doesn't exist. (when (and (not (get-file-buffer filename)) @@ -1457,7 +1457,7 @@ CHOICE is a list of the choice char and help message at IDX." (setq tchar (read-char)) (when (not (assq tchar choice)) (setq tchar nil) - (setq buf (get-buffer-create "*Gnus Help*")) + (setq buf (gnus-get-buffer-create "*Gnus Help*")) (pop-to-buffer buf) (fundamental-mode) (buffer-disable-undo) @@ -1601,10 +1601,10 @@ empty directories from OLD-PATH." (file-truename (concat old-dir ".."))))))))) -(defun gnus-set-file-modes (filename mode) +(defun gnus-set-file-modes (filename mode &optional flag) "Wrapper for set-file-modes." (ignore-errors - (set-file-modes filename mode))) + (set-file-modes filename mode flag))) (defun gnus-rescale-image (image size) "Rescale IMAGE to SIZE if possible. diff --git a/lisp/gnus/gnus-uu.el b/lisp/gnus/gnus-uu.el index 5902f2b37a7..70aeac00d7f 100644 --- a/lisp/gnus/gnus-uu.el +++ b/lisp/gnus/gnus-uu.el @@ -1674,7 +1674,7 @@ Gnus might fail to display all of it.") did-unpack)) (defun gnus-uu-dir-files (dir) - (let ((dirs (directory-files dir t (rx (or (not ".") "...")))) + (let ((dirs (directory-files dir t directory-files-no-dot-files-regexp)) files file) (while dirs (if (file-directory-p (setq file (car dirs))) @@ -1781,8 +1781,8 @@ Gnus might fail to display all of it.") gnus-uu-tmp-dir))) (setq gnus-uu-work-dir - (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir)) - (gnus-set-file-modes gnus-uu-work-dir 448) + (with-file-modes #o700 + (make-temp-file (concat gnus-uu-tmp-dir "gnus") 'dir))) (setq gnus-uu-work-dir (file-name-as-directory gnus-uu-work-dir)) (push (cons gnus-newsgroup-name gnus-uu-work-dir) gnus-uu-tmp-alist)))) diff --git a/lisp/gnus/gnus.el b/lisp/gnus/gnus.el index 6df26b4af8c..69f2bb27993 100644 --- a/lisp/gnus/gnus.el +++ b/lisp/gnus/gnus.el @@ -660,7 +660,7 @@ be used directly.") (defun gnus-add-buffer () "Add the current buffer to the list of Gnus buffers." (gnus-prune-buffers) - (push (current-buffer) gnus-buffers)) + (cl-pushnew (current-buffer) gnus-buffers)) (defmacro gnus-kill-buffer (buffer) "Kill BUFFER and remove from the list of Gnus buffers." @@ -2226,8 +2226,8 @@ Disabling the agent may result in noticeable loss of performance." :group 'gnus-start :type '(choice (function-item gnus) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (declare-function gnus-group-get-new-news "gnus-group") @@ -2238,8 +2238,8 @@ Disabling the agent may result in noticeable loss of performance." :type '(choice (function-item gnus) (function-item gnus-group-get-new-news) (function-item gnus-no-server) - (function-item gnus-slave) - (function-item gnus-slave-no-server))) + (function-item gnus-child) + (function-item gnus-child-no-server))) (defcustom gnus-other-frame-parameters nil "Frame parameters used by `gnus-other-frame' to create a Gnus frame." @@ -2417,8 +2417,8 @@ such as a mark that says whether an article is stored in the cache (defvar gnus-article-buffer "*Article*") (defvar gnus-server-buffer "*Server*") -(defvar gnus-slave nil - "Whether this Gnus is a slave or not.") +(defvar gnus-child nil + "Whether this Gnus is a child or not.") (defvar gnus-batch-mode nil "Whether this Gnus is running in batch mode or not.") @@ -4034,13 +4034,20 @@ Allow completion over sensible values." ;;; User-level commands. ;;;###autoload +(defun gnus-child-no-server (&optional arg) + "Read network news as a child, without connecting to the local server." + (interactive "P") + (gnus-no-server arg t)) + +;;;###autoload (defun gnus-slave-no-server (&optional arg) - "Read network news as a slave, without connecting to the local server." + "Read network news as a child, without connecting to the local server." (interactive "P") (gnus-no-server arg t)) +(make-obsolete 'gnus-slave-no-server 'gnus-child-no-server "28.1") ;;;###autoload -(defun gnus-no-server (&optional arg slave) +(defun gnus-no-server (&optional arg child) "Read network news. If ARG is a positive number, Gnus will use that as the startup level. If ARG is nil, Gnus will be started at level 2. If ARG is non-nil @@ -4049,13 +4056,20 @@ an NNTP server to use. As opposed to `gnus', this command will not connect to the local server." (interactive "P") - (gnus-no-server-1 arg slave)) + (gnus-no-server-1 arg child)) + +;;;###autoload +(defun gnus-child (&optional arg) + "Read news as a child." + (interactive "P") + (gnus arg nil 'child)) ;;;###autoload (defun gnus-slave (&optional arg) - "Read news as a slave." + "Read news as a child." (interactive "P") - (gnus arg nil 'slave)) + (gnus arg nil 'child)) +(make-obsolete 'gnus-slave 'gnus-child "28.1") (defun gnus-delete-gnus-frame () "Delete gnus frame unless it is the only one. @@ -4116,7 +4130,7 @@ current display is used." (add-hook 'gnus-suspend-gnus-hook #'gnus-delete-gnus-frame))))) ;;;###autoload -(defun gnus (&optional arg dont-connect slave) +(defun gnus (&optional arg dont-connect child) "Read network news. If ARG is non-nil and a positive number, Gnus will use that as the startup level. If ARG is non-nil and not a positive number, Gnus will @@ -4130,7 +4144,7 @@ prompt the user for the name of an NNTP server to use." (message "You should byte-compile Gnus") (sit-for 2)) (let ((gnus-action-message-log (list nil))) - (gnus-1 arg dont-connect slave) + (gnus-1 arg dont-connect child) (gnus-final-warning))) (declare-function debbugs-gnu "ext:debbugs-gnu" diff --git a/lisp/gnus/gssapi.el b/lisp/gnus/gssapi.el index 218a1542e3a..485d58ad94e 100644 --- a/lisp/gnus/gssapi.el +++ b/lisp/gnus/gssapi.el @@ -25,8 +25,6 @@ ;;; Code: -(require 'format-spec) - (defcustom gssapi-program (list (concat "gsasl %s %p " "--mechanism GSSAPI " @@ -53,12 +51,9 @@ tried until a successful connection is made." (coding-system-for-write 'binary) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,user))))) response) (when process (while (and (memq (process-status process) '(open run)) diff --git a/lisp/gnus/mail-source.el b/lisp/gnus/mail-source.el index 52343d4fa37..43180726c45 100644 --- a/lisp/gnus/mail-source.el +++ b/lisp/gnus/mail-source.el @@ -24,7 +24,6 @@ ;;; Code: -(require 'format-spec) (eval-when-compile (require 'cl-lib) (require 'imap)) @@ -695,7 +694,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) mail-source-movemail-program nil errors nil from to))))) (when (file-exists-p to) - (set-file-modes to mail-source-default-file-modes)) + (set-file-modes to mail-source-default-file-modes 'nofollow)) (if (and (or (not (buffer-modified-p errors)) (zerop (buffer-size errors))) (and (numberp result) @@ -740,9 +739,11 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (when delay (sleep-for delay))) +(declare-function gnus-get-buffer-create "gnus" (name)) (defun mail-source-call-script (script) + (require 'gnus) (let ((background nil) - (stderr (get-buffer-create " *mail-source-stderr*")) + (stderr (gnus-get-buffer-create " *mail-source-stderr*")) result) (when (string-match "& *$" script) (setq script (substring script 0 (match-beginning 0)) @@ -767,14 +768,14 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for single-file sources." (mail-source-bind (file source) (mail-source-run-script - prescript (format-spec-make ?t mail-source-crash-box) + prescript `((?t . ,mail-source-crash-box)) prescript-delay) (let ((mail-source-string (format "file:%s" path))) (if (mail-source-movemail path mail-source-crash-box) (prog1 (mail-source-callback callback path) (mail-source-run-script - postscript (format-spec-make ?t mail-source-crash-box)) + postscript `((?t . ,mail-source-crash-box))) (mail-source-delete-crash-box)) 0)))) @@ -782,7 +783,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) "Fetcher for directory sources." (mail-source-bind (directory source) (mail-source-run-script - prescript (format-spec-make ?t path) prescript-delay) + prescript `((?t . ,path)) prescript-delay) (let ((found 0) (mail-source-string (format "directory:%s" path))) (dolist (file (directory-files @@ -791,7 +792,7 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (funcall predicate file) (mail-source-movemail file mail-source-crash-box)) (cl-incf found (mail-source-callback callback file)) - (mail-source-run-script postscript (format-spec-make ?t path)) + (mail-source-run-script postscript `((?t . ,path))) (mail-source-delete-crash-box))) found))) @@ -801,8 +802,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) ;; fixme: deal with stream type in format specs (mail-source-run-script prescript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (mail-source-string (format "pop:%s@%s" user server)) @@ -823,8 +824,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (mail-source-fetch-with-program (format-spec program - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)))) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))))) (function (funcall function mail-source-crash-box)) ;; The default is to use pop3.el. @@ -861,8 +862,8 @@ Deleting old (> %s day(s)) incoming mail file `%s'." diff bfile) (setq mail-source-new-mail-available nil)) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) (mail-source-delete-crash-box))) ;; We nix out the password in case the error ;; was because of a wrong password being given. @@ -1075,8 +1076,9 @@ This only works when `display-time' is enabled." "Fetcher for imap sources." (mail-source-bind (imap source) (mail-source-run-script - prescript (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user) + prescript + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user)) prescript-delay) (let ((from (format "%s:%s:%s" server user port)) (found 0) @@ -1141,8 +1143,8 @@ This only works when `display-time' is enabled." (kill-buffer buf) (mail-source-run-script postscript - (format-spec-make ?p password ?t mail-source-crash-box - ?s server ?P port ?u user)) + `((?p . ,password) (?t . ,mail-source-crash-box) + (?s . ,server) (?P . ,port) (?u . ,user))) found))) (provide 'mail-source) diff --git a/lisp/gnus/message.el b/lisp/gnus/message.el index cbdd329f3ec..fb560f0eab8 100644 --- a/lisp/gnus/message.el +++ b/lisp/gnus/message.el @@ -42,13 +42,12 @@ (require 'mail-parse) (require 'mml) (require 'rfc822) -(require 'format-spec) (require 'dired) (require 'mm-util) (require 'rfc2047) (require 'puny) -(require 'rmc) ; read-multiple-choice -(eval-when-compile (require 'subr-x)) ; when-let* +(require 'rmc) ; read-multiple-choice +(eval-when-compile (require 'subr-x)) (autoload 'mailclient-send-it "mailclient") @@ -215,9 +214,9 @@ Also see `message-required-news-headers' and :link '(custom-manual "(message)Message Headers") :type '(repeat sexp)) -(defcustom message-draft-headers '(References From Date) +(defcustom message-draft-headers '(References From) "Headers to be generated when saving a draft message." - :version "22.1" + :version "28.1" :group 'message-news :group 'message-headers :link '(custom-manual "(message)Message Headers") @@ -322,7 +321,7 @@ used." :group 'message-various) (defcustom message-subject-trailing-was-ask-regexp - "[ \t]*\\([[(]+[Ww][Aa][Ss]:?[ \t]*.*[])]+\\)" + "[ \t]*\\([[(]+[Ww][Aa][Ss].*[])]+\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. The function `message-strip-subject-trailing-was' uses this regexp if @@ -337,7 +336,7 @@ It is okay to create some false positives here, as the user is asked." :type 'regexp) (defcustom message-subject-trailing-was-regexp - "[ \t]*\\((*[Ww][Aa][Ss]:[ \t]*.*)\\)" + "[ \t]*\\((*[Ww][Aa][Ss]:.*)\\)" "Regexp matching \"(was: <old subject>)\" in the subject line. If `message-subject-trailing-was-query' is set to t, the subject is @@ -440,8 +439,8 @@ whitespace)." (defcustom message-elide-ellipsis "\n[...]\n\n" "The string which is inserted for elided text. -This is a format-spec string, and you can use %l to say how many -lines were removed, and %c to say how many characters were +This is a `format-spec' string, and you can use %l to say how +many lines were removed, and %c to say how many characters were removed." :type 'string :link '(custom-manual "(message)Various Commands") @@ -1986,6 +1985,7 @@ You must have the \"hashcash\" binary installed, see `hashcash-path'." (autoload 'gnus-delay-article "gnus-delay") (autoload 'gnus-extract-address-components "gnus-util") (autoload 'gnus-find-method-for-group "gnus") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'gnus-group-name-charset "gnus-group") (autoload 'gnus-group-name-decode "gnus-group") (autoload 'gnus-groups-from-server "gnus") @@ -3976,7 +3976,6 @@ This function uses `mail-citation-hook' if that is non-nil." "Cite function in the standard Message manner." (message-cite-original-1 nil)) -(autoload 'format-spec "format-spec") (autoload 'gnus-date-get-time "gnus-util") (defun message-insert-formatted-citation-line (&optional from date tz) @@ -4001,20 +4000,18 @@ See `message-citation-line-format'." (when (or message-reply-headers (and from date)) (unless from (setq from (mail-header-from message-reply-headers))) - (let* ((data (condition-case () - (funcall (if (boundp 'gnus-extract-address-components) - gnus-extract-address-components - 'mail-extract-address-components) - from) - (error nil))) + (let* ((data (ignore-errors + (funcall (or (bound-and-true-p + gnus-extract-address-components) + #'mail-extract-address-components) + from))) (name (car data)) (fname name) (lname name) - (net (car (cdr data))) - (name-or-net (or (car data) - (car (cdr data)) from)) + (net (cadr data)) + (name-or-net (or name net from)) (time - (when (string-match "%[^fnNFL]" message-citation-line-format) + (when (string-match-p "%[^FLNfn]" message-citation-line-format) (cond ((numberp (car-safe date)) date) ;; backward compatibility (date (gnus-date-get-time date)) (t @@ -4023,68 +4020,53 @@ See `message-citation-line-format'." (tz (or tz (when (stringp date) (nth 8 (parse-time-string date))))) - (flist - (let ((i ?A) lst) - (when (stringp name) - ;; Guess first name and last name: - (let* ((names (delq - nil - (mapcar - (lambda (x) - (if (string-match "\\`\\(\\w\\|[-.]\\)+\\'" - x) - x - nil)) - (split-string name "[ \t]+")))) - (count (length names))) - (cond ((= count 1) - (setq fname (car names) - lname "")) - ((or (= count 2) (= count 3)) - (setq fname (car names) - lname (mapconcat 'identity (cdr names) " "))) - ((> count 3) - (setq fname (mapconcat 'identity - (butlast names (- count 2)) - " ") - lname (mapconcat 'identity - (nthcdr 2 names) - " ")))) - (when (string-match "\\(.*\\),\\'" fname) - (let ((newlname (match-string 1 fname))) - (setq fname lname lname newlname))))) - ;; The following letters are not used in `format-time-string': - (push ?E lst) (push "<E>" lst) - (push ?F lst) (push (or fname name-or-net) lst) - ;; We might want to use "" instead of "<X>" later. - (push ?J lst) (push "<J>" lst) - (push ?K lst) (push "<K>" lst) - (push ?L lst) (push lname lst) - (push ?N lst) (push name-or-net lst) - (push ?O lst) (push "<O>" lst) - (push ?P lst) (push "<P>" lst) - (push ?Q lst) (push "<Q>" lst) - (push ?f lst) (push from lst) - (push ?i lst) (push "<i>" lst) - (push ?n lst) (push net lst) - (push ?o lst) (push "<o>" lst) - (push ?q lst) (push "<q>" lst) - (push ?t lst) (push "<t>" lst) - (push ?v lst) (push "<v>" lst) - ;; Delegate the rest to `format-time-string': - (while (<= i ?z) - (when (and (not (memq i lst)) - ;; Skip (Z,a) - (or (<= i ?Z) - (>= i ?a))) - (push i lst) - (push (condition-case nil - (format-time-string (format "%%%c" i) time tz) - (error (format ">%c<" i))) - lst)) - (setq i (1+ i))) - (reverse lst))) - (spec (apply 'format-spec-make flist))) + spec) + (when (stringp name) + ;; Guess first name and last name: + (let* ((names (seq-filter + (lambda (s) + (string-match-p (rx bos (+ (in word ?. ?-)) eos) s)) + (split-string name "[ \t]+"))) + (count (length names))) + (cond ((= count 1) + (setq fname (car names) + lname "")) + ((or (= count 2) (= count 3)) + (setq fname (car names) + lname (string-join (cdr names) " "))) + ((> count 3) + (setq fname (string-join (butlast names (- count 2)) + " ") + lname (string-join (nthcdr 2 names) " ")))) + (when (string-match "\\(.*\\),\\'" fname) + (let ((newlname (match-string 1 fname))) + (setq fname lname lname newlname))))) + ;; The following letters are not used in `format-time-string': + (push (cons ?E "<E>") spec) + (push (cons ?F (or fname name-or-net)) spec) + ;; We might want to use "" instead of "<X>" later. + (push (cons ?J "<J>") spec) + (push (cons ?K "<K>") spec) + (push (cons ?L lname) spec) + (push (cons ?N name-or-net) spec) + (push (cons ?O "<O>") spec) + (push (cons ?P "<P>") spec) + (push (cons ?Q "<Q>") spec) + (push (cons ?f from) spec) + (push (cons ?i "<i>") spec) + (push (cons ?n net) spec) + (push (cons ?o "<o>") spec) + (push (cons ?q "<q>") spec) + (push (cons ?t "<t>") spec) + (push (cons ?v "<v>") spec) + ;; Delegate the rest to `format-time-string': + (dolist (c (nconc (number-sequence ?A ?Z) + (number-sequence ?a ?z))) + (unless (assq c spec) + (push (cons c (condition-case nil + (format-time-string (format "%%%c" c) time tz) + (error (format ">%c<" c)))) + spec))) (insert (format-spec message-citation-line-format spec))) (newline))) @@ -7310,7 +7292,7 @@ If ARG, allow editing of the cancellation message." ;; Make control message. (if arg (message-news) - (setq buf (set-buffer (get-buffer-create " *message cancel*")))) + (setq buf (set-buffer (gnus-get-buffer-create " *message cancel*")))) (erase-buffer) (insert "Newsgroups: " newsgroups "\n" "From: " from "\n" @@ -7731,7 +7713,7 @@ is for the internal use." gcc beg) ;; We first set up a normal mail buffer. (unless (message-mail-user-agent) - (set-buffer (get-buffer-create " *message resend*")) + (set-buffer (gnus-get-buffer-create " *message resend*")) (let ((inhibit-read-only t)) (erase-buffer))) (let ((message-this-is-mail t) @@ -7983,7 +7965,7 @@ See `gmm-tool-bar-from-list' for details on the format of the list." (defcustom message-tool-bar-retro '(;; Old Emacs 21 icon for consistency. - (message-send-and-exit "gnus/mail-send") + (message-send-and-exit "mail/send") (message-kill-buffer "close") (message-dont-send "cancel") (mml-attach-file "attach" mml-mode-map) diff --git a/lisp/gnus/mm-archive.el b/lisp/gnus/mm-archive.el index 6b4308e9790..56253afa193 100644 --- a/lisp/gnus/mm-archive.el +++ b/lisp/gnus/mm-archive.el @@ -24,6 +24,7 @@ (require 'mm-decode) (autoload 'gnus-recursive-directory-files "gnus-util") +(autoload 'gnus-get-buffer-create "gnus") (autoload 'mailcap-extension-to-mime "mailcap") (defvar mm-archive-decoders @@ -41,8 +42,9 @@ dir) (unless decoder (error "No decoder found for %s" type)) - (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) 'dir)) - (set-file-modes dir #o700) + (with-file-modes #o700 + (setq dir (make-temp-file (expand-file-name "emm." mm-tmp-directory) + 'dir))) (unwind-protect (progn (mm-with-unibyte-buffer @@ -56,7 +58,7 @@ (append (cdr decoder) (list dir))) (delete-file file)) (apply 'call-process-region (point-min) (point-max) (car decoder) - nil (get-buffer-create "*tnef*") + nil (gnus-get-buffer-create "*tnef*") nil (append (cdr decoder) (list dir))))) `("multipart/mixed" ,handle diff --git a/lisp/gnus/mm-decode.el b/lisp/gnus/mm-decode.el index a340418507f..587c4e01b92 100644 --- a/lisp/gnus/mm-decode.el +++ b/lisp/gnus/mm-decode.el @@ -602,11 +602,10 @@ files left at the next time." (push temp fails))) (if fails ;; Schedule the deletion of the files left at the next time. - (progn + (with-file-modes #o600 (write-region (concat (mapconcat 'identity (nreverse fails) "\n") "\n") - nil cache-file nil 'silent) - (set-file-modes cache-file #o600)) + nil cache-file nil 'silent)) (when (file-exists-p cache-file) (ignore-errors (delete-file cache-file)))) (setq mm-temp-files-to-be-deleted nil))) @@ -911,8 +910,10 @@ external if displayed external." ;; The function is a string to be executed. (mm-insert-part handle) (mm-add-meta-html-tag handle) - (let* ((dir (make-temp-file - (expand-file-name "emm." mm-tmp-directory) 'dir)) + ;; We create a private sub-directory where we store our files. + (let* ((dir (with-file-modes #o700 + (make-temp-file + (expand-file-name "emm." mm-tmp-directory) 'dir))) (filename (or (mail-content-type-get (mm-handle-disposition handle) 'filename) @@ -924,8 +925,6 @@ external if displayed external." (assoc "needsterminal" mime-info))) (copiousoutput (assoc "copiousoutput" mime-info)) file buffer) - ;; We create a private sub-directory where we store our files. - (set-file-modes dir #o700) (if filename (setq file (expand-file-name (gnus-map-function mm-file-name-rewrite-functions @@ -941,14 +940,15 @@ external if displayed external." ;; `mailcap-mime-extensions'. (setq suffix (car (rassoc (mm-handle-media-type handle) mailcap-mime-extensions)))) - (setq file (make-temp-file (expand-file-name "mm." dir) - nil suffix)))) + (setq file (with-file-modes #o600 + (make-temp-file (expand-file-name "mm." dir) + nil suffix))))) (let ((coding-system-for-write mm-binary-coding-system)) (write-region (point-min) (point-max) file nil 'nomesg)) ;; The file is deleted after the viewer exists. If the users edits ;; the file, changes will be lost. Set file to read-only to make it ;; clear. - (set-file-modes file #o400) + (set-file-modes file #o400 'nofollow) (message "Viewing with %s" method) (cond (needsterm diff --git a/lisp/gnus/mm-uu.el b/lisp/gnus/mm-uu.el index e6fdc93da24..aedd6c948c2 100644 --- a/lisp/gnus/mm-uu.el +++ b/lisp/gnus/mm-uu.el @@ -192,7 +192,7 @@ This can be either \"inline\" or \"attachment\".") ,(lambda () (mm-uu-verbatim-marks-extract 0 0)) nil) (LaTeX - "^\\([\\\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" + "^\\([\\%][^\n]+\n\\)*\\\\documentclass.*[[{%]" "^\\\\end{document}" ,#'mm-uu-latex-extract nil @@ -251,19 +251,23 @@ The value should be nil on displays where the face (((type tty) (class color) (background dark)) - (:background "dark blue")) + (:background "dark blue" + :extend t)) (((class color) (background dark)) (:foreground "light yellow" - :background "dark green")) + :background "dark green" + :extend t)) (((type tty) (class color) (background light)) - (:foreground "dark blue")) + (:foreground "dark blue" + :extend t)) (((class color) (background light)) (:foreground "dark green" - :background "light yellow")) + :background "light yellow" + :extend t)) (t ())) "Face for extracted buffers." diff --git a/lisp/gnus/mml-smime.el b/lisp/gnus/mml-smime.el index 3cc463d5d4c..4754f37a2da 100644 --- a/lisp/gnus/mml-smime.el +++ b/lisp/gnus/mml-smime.el @@ -154,14 +154,9 @@ Whether the passphrase is cached at all is controlled by (write-region (point-min) (point-max) file)) (push file certfiles) (push file tmpfiles))) - (if (smime-encrypt-buffer certfiles) - (progn - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - t) - (while (setq tmp (pop tmpfiles)) - (delete-file tmp)) - nil)) + (smime-encrypt-buffer certfiles) + (while (setq tmp (pop tmpfiles)) + (delete-file tmp))) (goto-char (point-max))) (defvar gnus-extract-address-components) diff --git a/lisp/gnus/mml.el b/lisp/gnus/mml.el index 556cf0804a5..21491499eb8 100644 --- a/lisp/gnus/mml.el +++ b/lisp/gnus/mml.el @@ -487,11 +487,8 @@ type detected." (= (length cont) 1) content-type) (setcdr (assq 'type (cdr (car cont))) content-type)) - (when (and (consp (car cont)) - (= (length cont) 1) - (fboundp 'libxml-parse-html-region) - (equal (cdr (assq 'type (car cont))) "text/html")) - (setq cont (mml-expand-html-into-multipart-related (car cont)))) + (when (fboundp 'libxml-parse-html-region) + (setq cont (mapcar 'mml-expand-all-html-into-multipart-related cont))) (prog1 (with-temp-buffer (set-buffer-multibyte nil) @@ -510,6 +507,18 @@ type detected." (buffer-string)) (setq message-options options))))) +(defun mml-expand-all-html-into-multipart-related (cont) + (cond ((and (eq (car cont) 'part) + (equal (cdr (assq 'type cont)) "text/html")) + (mml-expand-html-into-multipart-related cont)) + ((eq (car cont) 'multipart) + (let ((cur (cdr cont))) + (while (consp cur) + (setcar cur (mml-expand-all-html-into-multipart-related (car cur))) + (setf cur (cdr cur)))) + cont) + (t cont))) + (defun mml-expand-html-into-multipart-related (cont) (let ((new-parts nil) (cid 1)) @@ -538,8 +547,7 @@ type detected." new-parts)) (setq cid (1+ cid))))))) ;; We have local images that we want to include. - (if (not new-parts) - (list cont) + (when new-parts (setcdr (assq 'contents cont) (buffer-string)) (setq cont (nconc (list 'multipart (cons 'type "related")) @@ -552,8 +560,8 @@ type detected." (nth 1 new-part) (nth 2 new-part)) (id . ,(concat "<" (nth 0 new-part) - ">"))))))) - cont)))) + ">")))))))) + cont))) (autoload 'image-property "image") diff --git a/lisp/gnus/mml2015.el b/lisp/gnus/mml2015.el index 1e72f681797..d1d150ad2ee 100644 --- a/lisp/gnus/mml2015.el +++ b/lisp/gnus/mml2015.el @@ -293,6 +293,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (substring alg (match-end 0)) alg)))) +(autoload 'gnus-get-buffer-create "gnus") + (defun mml2015-mailcrypt-verify (handle ctl) (catch 'error (let (part) @@ -330,7 +332,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (replace-match "-----BEGIN PGP SIGNATURE-----" t t)) (if (re-search-forward "^-----END PGP [^-]+-----\r?$" nil t) (replace-match "-----END PGP SIGNATURE-----" t t))) - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (unless (condition-case err (prog1 (funcall mml2015-verify-function) @@ -359,7 +361,7 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." handle))) (defun mml2015-mailcrypt-clear-verify () - (let ((mc-gpg-debug-buffer (get-buffer-create " *gnus gpg debug*"))) + (let ((mc-gpg-debug-buffer (gnus-get-buffer-create " *gnus gpg debug*"))) (if (condition-case err (prog1 (funcall mml2015-verify-function) @@ -725,6 +727,8 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." (autoload 'epg-expand-group "epg-config") (autoload 'epa-select-keys "epa") +(autoload 'gnus-create-image "gnus-util") + (defun mml2015-epg-key-image (key-id) "Return the image of a key, if any." (with-temp-buffer @@ -949,7 +953,6 @@ If set, it overrides the setting of `mml2015-sign-with-sender'." ;;; General wrapper (autoload 'gnus-buffer-live-p "gnus-util") -(autoload 'gnus-get-buffer-create "gnus") (defun mml2015-clean-buffer () (if (gnus-buffer-live-p mml2015-result-buffer) diff --git a/lisp/gnus/nnbabyl.el b/lisp/gnus/nnbabyl.el index 6890f1dceeb..480d794b9ac 100644 --- a/lisp/gnus/nnbabyl.el +++ b/lisp/gnus/nnbabyl.el @@ -293,7 +293,7 @@ (deffoo nnbabyl-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnbabyl move*")) + (let ((buf (gnus-get-buffer-create " *nnbabyl move*")) result) (and (nnbabyl-request-article article group server) @@ -544,7 +544,7 @@ (setq buffer-file-name nnbabyl-mbox-file) (insert "BABYL OPTIONS:\n\n\^_") (nnmail-write-region - (point-min) (point-max) nnbabyl-mbox-file t 'nomesg)))) + (point-min) (point-max) nnbabyl-mbox-file t 'nomesg nil 'excl)))) (defun nnbabyl-read-mbox () (nnmail-activate 'nnbabyl) diff --git a/lisp/gnus/nndiary.el b/lisp/gnus/nndiary.el index 24a3df1e27a..945ef0351e5 100644 --- a/lisp/gnus/nndiary.el +++ b/lisp/gnus/nndiary.el @@ -597,7 +597,7 @@ all. This may very well take some time.") (deffoo nndiary-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nndiary move*")) + (let ((buf (gnus-get-buffer-create " *nndiary move*")) result) (nndiary-possibly-change-directory group server) (nndiary-update-file-alist) @@ -831,7 +831,7 @@ all. This may very well take some time.") ;; Find an article number in the current group given the Message-ID. (defun nndiary-find-group-number (id) - (with-current-buffer (get-buffer-create " *nndiary id*") + (with-current-buffer (gnus-get-buffer-create " *nndiary id*") (let ((alist nndiary-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -999,8 +999,8 @@ all. This may very well take some time.") (defun nndiary-open-nov (group) (or (cdr (assoc group nndiary-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nndiary overview %s*" - group)))) + (let ((buffer (gnus-get-buffer-create + (format " *nndiary overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nndiary-nov-buffer-file-name) (expand-file-name @@ -1086,7 +1086,7 @@ all. This may very well take some time.") (defun nndiary-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nndiary-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) ;; Init the nov buffer. (with-current-buffer nov-buffer @@ -1115,7 +1115,7 @@ all. This may very well take some time.") (widen)) (setq files (cdr files))) (with-current-buffer nov-buffer - (nnmail-write-region 1 (point-max) nov nil 'nomesg) + (nnmail-write-region 1 (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nndiary-nov-delete-article (group article) diff --git a/lisp/gnus/nndoc.el b/lisp/gnus/nndoc.el index 0ba63915c94..36b67a8fd13 100644 --- a/lisp/gnus/nndoc.el +++ b/lisp/gnus/nndoc.el @@ -347,7 +347,7 @@ from the document.") (file-exists-p nndoc-address) (not (file-directory-p nndoc-address)))) (push (cons group (setq nndoc-current-buffer - (get-buffer-create + (gnus-get-buffer-create (concat " *nndoc " group "*")))) nndoc-group-alist) (setq nndoc-dissection-alist nil) diff --git a/lisp/gnus/nndraft.el b/lisp/gnus/nndraft.el index a1337e8d7fa..a3c26ea4ac0 100644 --- a/lisp/gnus/nndraft.el +++ b/lisp/gnus/nndraft.el @@ -231,7 +231,7 @@ are generated if and only if they are also in `message-draft-headers'." (deffoo nndraft-request-move-article (article group server accept-form &optional last move-is-internal) (nndraft-possibly-change-group group) - (let ((buf (get-buffer-create " *nndraft move*")) + (let ((buf (gnus-get-buffer-create " *nndraft move*")) result) (and (nndraft-request-article article group server) @@ -325,7 +325,7 @@ are generated if and only if they are also in `message-draft-headers'." (save-excursion (prog1 (progn - (set-buffer (get-buffer-create " *draft tmp*")) + (set-buffer (gnus-get-buffer-create " *draft tmp*")) (setq buffer-file-name file) (make-auto-save-file-name)) (kill-buffer (current-buffer))))) diff --git a/lisp/gnus/nneething.el b/lisp/gnus/nneething.el index 9e190515f18..9f1fdbae5ae 100644 --- a/lisp/gnus/nneething.el +++ b/lisp/gnus/nneething.el @@ -381,7 +381,7 @@ included.") (defun nneething-get-head (file) "Either find the head in FILE or make a head for FILE." - (with-current-buffer (get-buffer-create nneething-work-buffer) + (with-current-buffer (gnus-get-buffer-create nneething-work-buffer) (setq case-fold-search nil) (buffer-disable-undo) (erase-buffer) diff --git a/lisp/gnus/nnfolder.el b/lisp/gnus/nnfolder.el index 342ac48ba85..c27af1742d8 100644 --- a/lisp/gnus/nnfolder.el +++ b/lisp/gnus/nnfolder.el @@ -465,7 +465,7 @@ all. This may very well take some time.") (deffoo nnfolder-request-move-article (article group server accept-form &optional last move-is-internal) (save-excursion - (let ((buf (get-buffer-create " *nnfolder move*")) + (let ((buf (gnus-get-buffer-create " *nnfolder move*")) result) (and (nnfolder-request-article article group server) @@ -735,7 +735,7 @@ deleted. Point is left where the deleted region was." (or nnfolder-file-coding-system-for-write nnfolder-file-coding-system-for-write))) (nnmail-write-region (point-min) (point-min) - file t 'nomesg))) + file t 'nomesg nil 'excl))) (when (setq nnfolder-current-buffer (nnfolder-read-folder group)) (set-buffer nnfolder-current-buffer) (push (list group nnfolder-current-buffer) @@ -1096,7 +1096,7 @@ This command does not work if you use short group names." (defun nnfolder-open-nov (group) (or (cdr (assoc group nnfolder-nov-buffer-alist)) - (let ((buffer (get-buffer-create (format " *nnfolder overview %s*" group)))) + (let ((buffer (gnus-get-buffer-create (format " *nnfolder overview %s*" group)))) (with-current-buffer buffer (set (make-local-variable 'nnfolder-nov-buffer-file-name) (nnfolder-group-nov-pathname group)) diff --git a/lisp/gnus/nnheader.el b/lisp/gnus/nnheader.el index 03b08854b11..fee7a169ff9 100644 --- a/lisp/gnus/nnheader.el +++ b/lisp/gnus/nnheader.el @@ -209,7 +209,7 @@ on your system, you could say something like: ;; about twice as fast, even though it looks messier. You ;; can't have everything, I guess. Speed and elegance don't ;; always go hand in hand. - (vector + (make-full-mail-header ;; Number. (or number 0) ;; Subject. @@ -487,8 +487,8 @@ the line could be found." (< num article))) (forward-line 1) (setq found (point)) - (or (eobp) - (= (setq num (read cur)) article))) + (unless (eobp) + (setq num (read cur)))) (unless (eq num article) (goto-char found))) (beginning-of-line) @@ -502,10 +502,12 @@ the line could be found." "Coding system used in file backends of Gnus.") (defvar nnheader-callback-function nil) +(autoload 'gnus-get-buffer-create "gnus") + (defun nnheader-init-server-buffer () "Initialize the Gnus-backend communication buffer." (unless (gnus-buffer-live-p nntp-server-buffer) - (setq nntp-server-buffer (get-buffer-create " *nntpd*"))) + (setq nntp-server-buffer (gnus-get-buffer-create " *nntpd*"))) (with-current-buffer nntp-server-buffer (erase-buffer) (mm-enable-multibyte) @@ -630,7 +632,7 @@ the line could be found." (defun nnheader-set-temp-buffer (name &optional noerase) "Set-buffer to an empty (possibly new) buffer called NAME with undo disabled." - (set-buffer (get-buffer-create name)) + (set-buffer (gnus-get-buffer-create name)) (buffer-disable-undo) (unless noerase (erase-buffer)) diff --git a/lisp/gnus/nnimap.el b/lisp/gnus/nnimap.el index c383e0146f3..be8ad9a6723 100644 --- a/lisp/gnus/nnimap.el +++ b/lisp/gnus/nnimap.el @@ -1670,8 +1670,7 @@ If LIMIT, first try to limit the search to the N last articles." (when (and active recent (> (car (last recent)) (cdr active))) - (push (list (cons (gnus-group-real-name group) 0)) - nnmail-split-history))) + (push (list (cons group 0)) nnmail-split-history))) ;; Note the active level for the next run-through. (gnus-group-set-parameter info 'active (gnus-active group)) (gnus-group-set-parameter info 'uidvalidity uidvalidity) @@ -1937,7 +1936,7 @@ Return the server's response to the SELECT or EXAMINE command." (defun nnimap-log-buffer () (let ((name "*imap log*")) (or (get-buffer name) - (with-current-buffer (get-buffer-create name) + (with-current-buffer (gnus-get-buffer-create name) (setq-local window-point-insertion-type t) (current-buffer))))) diff --git a/lisp/gnus/nnir.el b/lisp/gnus/nnir.el index f1e31a0cd10..722969c21ba 100644 --- a/lisp/gnus/nnir.el +++ b/lisp/gnus/nnir.el @@ -617,7 +617,8 @@ A non-nil `specs' arg must be an alist with `nnir-query-spec' and (list (gnus-group-group-name)) (mapcar (lambda (entry) (gnus-info-group (cadr entry))) - (gnus-topic-find-groups (gnus-group-topic-name))))) + (gnus-topic-find-groups (gnus-group-topic-name) + nil t nil t)))) gnus-group-server)))) (query-spec (or (cdr (assq 'nnir-query-spec specs)) @@ -1234,7 +1235,7 @@ Windows NT 4.0." (when (equal "" qstring) (error "swish++: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groupspec @@ -1316,7 +1317,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (when (equal "" qstring) (error "swish-e: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing swish-e query %s..." query) @@ -1401,7 +1402,7 @@ Tested with swish-e-2.0.1 on Windows NT 4.0." (setq groupspec (regexp-opt (mapcar (lambda (x) (gnus-group-real-name x)) group)))) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (message "Doing hyrex-search query %s..." query) (let* ((cp-list @@ -1480,7 +1481,7 @@ Tested with Namazu 2.0.6 on a GNU/Linux system." score group article (process-environment (copy-sequence process-environment))) (setenv "LC_MESSAGES" "C") - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (let* ((cp-list `( ,nnir-namazu-program @@ -1561,7 +1562,7 @@ construct path: search terms (see the variable (when (equal "" qstring) (error "notmuch: You didn't enter anything")) - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (erase-buffer) (if groups @@ -1635,7 +1636,7 @@ construct path: search terms (see the variable (message "Searching %s using find-grep..." (or group server)) (save-window-excursion - (set-buffer (get-buffer-create nnir-tmp-buffer)) + (set-buffer (gnus-get-buffer-create nnir-tmp-buffer)) (if (> gnus-verbose 6) (pop-to-buffer (current-buffer))) (cd directory) ; Using relative paths simplifies diff --git a/lisp/gnus/nnmail.el b/lisp/gnus/nnmail.el index d64d0ed0006..b6308140fc9 100644 --- a/lisp/gnus/nnmail.el +++ b/lisp/gnus/nnmail.el @@ -1047,7 +1047,7 @@ will be copied over from that buffer." (list (list group "")) nnmail-split-methods))) ;; Insert the incoming file. - (with-current-buffer (get-buffer-create nnmail-article-buffer) + (with-current-buffer (gnus-get-buffer-create nnmail-article-buffer) (erase-buffer) (if (bufferp incoming) (insert-buffer-substring incoming) @@ -1574,7 +1574,7 @@ See the documentation for the variable `nnmail-split-fancy' for details." () ; The buffer is open. (with-current-buffer (setq nnmail-cache-buffer - (get-buffer-create " *nnmail message-id cache*")) + (gnus-get-buffer-create " *nnmail message-id cache*")) (gnus-add-buffer) (when (file-exists-p nnmail-message-id-cache-file) (nnheader-insert-file-contents nnmail-message-id-cache-file)) @@ -1749,7 +1749,15 @@ See the Info node `(gnus)Fancy Mail Splitting' for more details." (nreverse (nnmail-article-group artnum-func)))))) ;; Add the group-art list to the history list. (if group-art - (push group-art nnmail-split-history) + ;; We need to get the unique Gnus group name for this article + ;; -- there may be identically named groups from several + ;; backends. + (push (mapcar + (lambda (ga) + (cons (gnus-group-prefixed-name (car ga) gnus-command-method) + (cdr ga))) + group-art) + nnmail-split-history) (delete-region (point-min) (point-max))))) ;;; Get new mail. @@ -1953,12 +1961,14 @@ If TIME is nil, then return the cutoff time for oldness instead." (unless (re-search-forward "^Message-ID[ \t]*:" nil t) (insert "Message-ID: " (nnmail-message-id) "\n"))))) -(defun nnmail-write-region (start end filename &optional append visit lockname) +(defun nnmail-write-region (start end filename + &optional append visit lockname mustbenew) "Do a `write-region', and then set the file modes." (let ((coding-system-for-write nnmail-file-coding-system) (file-name-coding-system nnmail-pathname-coding-system)) - (write-region start end filename append visit lockname) - (set-file-modes filename nnmail-default-file-modes))) + (write-region start end filename append visit lockname mustbenew) + (set-file-modes filename nnmail-default-file-modes + (when (eq mustbenew 'excl) 'nofollow)))) ;;; ;;; Status functions @@ -2065,7 +2075,7 @@ Doesn't change point." (when nnmail-split-tracing (push split nnmail-split-trace)) (when nnmail-debug-splitting - (with-current-buffer (get-buffer-create "*nnmail split*") + (with-current-buffer (gnus-get-buffer-create "*nnmail split*") (goto-char (point-max)) (insert (format-time-string "%FT%T") " " diff --git a/lisp/gnus/nnmaildir.el b/lisp/gnus/nnmaildir.el index b0e79d4f238..9c7b1254413 100644 --- a/lisp/gnus/nnmaildir.el +++ b/lisp/gnus/nnmaildir.el @@ -1,4 +1,4 @@ -;;; nnmaildir.el --- maildir backend for Gnus +;;; nnmaildir.el --- maildir backend for Gnus -*- lexical-binding:t -*- ;; This file is in the public domain. @@ -261,7 +261,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir--param (pgname param) (setq param (gnus-group-find-parameter pgname param 'allow-list)) (if (vectorp param) (setq param (aref param 0))) - (eval param)) + (eval param t)) (defmacro nnmaildir--with-nntp-buffer (&rest body) (declare (debug (body))) @@ -269,15 +269,15 @@ This variable is set by `nnmaildir-request-article'.") ,@body)) (defmacro nnmaildir--with-work-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir work*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir work*") ,@body)) (defmacro nnmaildir--with-nov-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir nov*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir nov*") ,@body)) (defmacro nnmaildir--with-move-buffer (&rest body) (declare (debug (body))) - `(with-current-buffer (get-buffer-create " *nnmaildir move*") + `(with-current-buffer (gnus-get-buffer-create " *nnmaildir move*") ,@body)) (defsubst nnmaildir--subdir (dir subdir) @@ -690,7 +690,7 @@ This variable is set by `nnmaildir-request-article'.") "You must set \"directory\" in the select method") (throw 'return nil)) (setq dir (cadr dir) - dir (eval dir) + dir (eval dir t) ;FIXME: Why `eval'? dir (expand-file-name dir) dir (file-name-as-directory dir)) (unless (file-exists-p dir) @@ -717,13 +717,13 @@ This variable is set by `nnmaildir-request-article'.") (if x (progn (setq x (cadr x) - x (eval x)) + x (eval x t)) ;FIXME: Why `eval'? (setf (nnmaildir--srv-target-prefix server) x)) (setq x (assq 'create-directory defs)) (if x (progn (setq x (cadr x) - x (eval x) + x (eval x t) ;FIXME: Why `eval'? x (file-name-as-directory x)) (setf (nnmaildir--srv-target-prefix server) x)) (setf (nnmaildir--srv-target-prefix server) ""))) @@ -1428,7 +1428,7 @@ This variable is set by `nnmaildir-request-article'.") (nnmaildir--with-move-buffer (erase-buffer) (nnheader-insert-file-contents nnmaildir--file) - (setq result (eval accept-form))) + (setq result (eval accept-form t))) (unless (or (null result) (nnmaildir--param pgname 'read-only)) (nnmaildir--unlink nnmaildir--file) (nnmaildir--expired-article group article)) @@ -1544,7 +1544,7 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-request-expire-articles (ranges &optional gname server force) (let ((no-force (not force)) (group (nnmaildir--prepare server gname)) - pgname time boundary high low target dir nlist + pgname time boundary target dir nlist didnt nnmaildir--file nnmaildir-article-file-name deactivate-mark) (catch 'return @@ -1720,18 +1720,23 @@ This variable is set by `nnmaildir-request-article'.") (defun nnmaildir-close-group (gname &optional server) (let ((group (nnmaildir--prepare server gname)) - pgname ls dir msgdir files flist dirs) + pgname ls dir msgdir files dirs + (fset (make-hash-table :test #'equal))) (if (null group) (progn (setf (nnmaildir--srv-error nnmaildir--cur-server) (concat "No such group: " gname)) nil) + ;; Delete the now obsolete NOV files. + ;; FIXME: This can take a somewhat long time, so maybe it's better + ;; to do it asynchronously (i.e. in an idle timer). (setq pgname (nnmaildir--pgname nnmaildir--cur-server gname) ls (nnmaildir--group-ls nnmaildir--cur-server pgname) dir (nnmaildir--srv-dir nnmaildir--cur-server) dir (nnmaildir--srvgrp-dir dir gname) msgdir (if (nnmaildir--param pgname 'read-only) (nnmaildir--new dir) (nnmaildir--cur dir)) + ;; The dir with the NOV files. dir (nnmaildir--nndir dir) dirs (cons (nnmaildir--nov-dir dir) (funcall ls (nnmaildir--marks-dir dir) 'full "\\`[^.]" @@ -1744,14 +1749,15 @@ This variable is set by `nnmaildir-request-article'.") (save-match-data (dolist (file files) (string-match "\\`\\([^:]*\\)\\(:.*\\)?\\'" file) - (push (match-string 1 file) flist))) + (puthash (match-string 1 file) t fset))) + ;; Not sure why, but we specifically avoid deleting the `:' file. + (puthash ":" t fset) (dolist (dir dirs) (setq files (cdr dir) dir (file-name-as-directory (car dir))) (dolist (file files) - (unless (or (member file flist) (string= file ":")) - (setq file (concat dir file)) - (delete-file file)))) + (unless (gethash file fset) + (delete-file (concat dir file))))) t))) (defun nnmaildir-close-server (&optional server _defs) diff --git a/lisp/gnus/nnmairix.el b/lisp/gnus/nnmairix.el index b3329212f84..dcecfcf6519 100644 --- a/lisp/gnus/nnmairix.el +++ b/lisp/gnus/nnmairix.el @@ -1249,7 +1249,7 @@ Marks propagation has to be enabled for this to work." If THREADS is non-nil, enable full threads." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1267,7 +1267,7 @@ If THREADS is non-nil, enable full threads." "Call mairix binary with COMMAND and QUERY in raw mode." (let ((args (cons (car command) '(nil t nil)))) (with-current-buffer - (get-buffer-create nnmairix-mairix-output-buffer) + (gnus-get-buffer-create nnmairix-mairix-output-buffer) (erase-buffer) (when (> (length command) 1) (setq args (append args (cdr command)))) @@ -1404,7 +1404,7 @@ TYPE is either `nov' or `headers'." (nnheader-message 7 "nnmairix: Rewriting headers...") (cond ((eq type 'nov) - (let ((buf (get-buffer-create " *nnmairix buffer*")) + (let ((buf (gnus-get-buffer-create " *nnmairix buffer*")) (corr (not (zerop numc))) (name (buffer-name nntp-server-buffer)) header cur xref) diff --git a/lisp/gnus/nnmbox.el b/lisp/gnus/nnmbox.el index eb8fcf37a25..8b3d80266e7 100644 --- a/lisp/gnus/nnmbox.el +++ b/lisp/gnus/nnmbox.el @@ -280,7 +280,7 @@ (deffoo nnmbox-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmbox move*")) + (let ((buf (gnus-get-buffer-create " *nnmbox move*")) result) (and (nnmbox-request-article article group server) @@ -613,7 +613,7 @@ (dir (file-name-directory nnmbox-mbox-file))) (and dir (gnus-make-directory dir)) (nnmail-write-region (point-min) (point-min) - nnmbox-mbox-file t 'nomesg)))) + nnmbox-mbox-file t 'nomesg nil 'excl)))) (defun nnmbox-read-mbox () (nnmail-activate 'nnmbox) diff --git a/lisp/gnus/nnmh.el b/lisp/gnus/nnmh.el index 8e7f0565e67..581a408009d 100644 --- a/lisp/gnus/nnmh.el +++ b/lisp/gnus/nnmh.el @@ -296,7 +296,7 @@ as unread by Gnus.") (deffoo nnmh-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnmh move*")) + (let ((buf (gnus-get-buffer-create " *nnmh move*")) result) (and (nnmh-deletable-article-p group article) diff --git a/lisp/gnus/nnml.el b/lisp/gnus/nnml.el index 6c7b25b5e76..baf5d54b74d 100644 --- a/lisp/gnus/nnml.el +++ b/lisp/gnus/nnml.el @@ -361,7 +361,7 @@ non-nil.") (deffoo nnml-request-move-article (article group server accept-form &optional last move-is-internal) - (let ((buf (get-buffer-create " *nnml move*")) + (let ((buf (gnus-get-buffer-create " *nnml move*")) (file-name-coding-system nnmail-pathname-coding-system) result) (nnml-possibly-change-directory group server) @@ -572,7 +572,7 @@ non-nil.") ;; Find an article number in the current group given the Message-ID. (defun nnml-find-group-number (id server) - (with-current-buffer (get-buffer-create " *nnml id*") + (with-current-buffer (gnus-get-buffer-create " *nnml id*") (let ((alist nnml-group-alist) number) ;; We want to look through all .overview files, but we want to @@ -772,11 +772,10 @@ article number. This function is called narrowed to an article." headers)))) (defun nnml-get-nov-buffer (group &optional incrementalp) - (let ((buffer (get-buffer-create (format " *nnml %soverview %s*" - (if incrementalp - "incremental " - "") - group))) + (let ((buffer (gnus-get-buffer-create + (format " *nnml %soverview %s*" + (if incrementalp "incremental " "") + group))) (file-name-coding-system nnmail-pathname-coding-system)) (with-current-buffer buffer (set (make-local-variable 'nnml-nov-buffer-file-name) @@ -873,7 +872,7 @@ Unless no-active is non-nil, update the active file too." (defun nnml-generate-nov-file (dir files) (let* ((dir (file-name-as-directory dir)) (nov (concat dir nnml-nov-file-name)) - (nov-buffer (get-buffer-create " *nov*")) + (nov-buffer (gnus-get-buffer-create " *nov*")) chars file headers) (with-current-buffer nov-buffer ;; Init the nov buffer. @@ -902,7 +901,7 @@ Unless no-active is non-nil, update the active file too." (nnheader-insert-nov headers))) (widen)))) (with-current-buffer nov-buffer - (nnmail-write-region (point-min) (point-max) nov nil 'nomesg) + (nnmail-write-region (point-min) (point-max) nov nil 'nomesg nil 'excl) (kill-buffer (current-buffer)))))) (defun nnml-nov-delete-article (group article) diff --git a/lisp/gnus/nnrss.el b/lisp/gnus/nnrss.el index fa4d22fb1cc..116d7ee9fb2 100644 --- a/lisp/gnus/nnrss.el +++ b/lisp/gnus/nnrss.el @@ -739,7 +739,7 @@ Read the file and attempt to subscribe to each Feed in the file." "OPML subscription export. Export subscriptions to a buffer in OPML Format." (interactive) - (with-current-buffer (get-buffer-create "*OPML Export*") + (with-current-buffer (gnus-get-buffer-create "*OPML Export*") (set-buffer-file-coding-system 'utf-8) (insert "<?xml version=\"1.0\" encoding=\"utf-8\"?>\n" "<!-- OPML generated by Emacs Gnus' nnrss.el -->\n" diff --git a/lisp/gnus/nntp.el b/lisp/gnus/nntp.el index 6ce8724cbbb..a5c82447926 100644 --- a/lisp/gnus/nntp.el +++ b/lisp/gnus/nntp.el @@ -309,7 +309,7 @@ backend doesn't catch this error.") (defun nntp-record-command (string) "Record the command STRING." - (with-current-buffer (get-buffer-create "*nntp-log*") + (with-current-buffer (gnus-get-buffer-create "*nntp-log*") (goto-char (point-max)) (insert (format-time-string "%Y%m%dT%H%M%S.%3N") " " nntp-address " " string "\n"))) @@ -1247,8 +1247,8 @@ If SEND-IF-FORCE, only send authinfo to the server if the (and nntp-connection-timeout (run-at-time nntp-connection-timeout nil - `(lambda () - (nntp-kill-buffer ,pbuffer))))) + (lambda () + (nntp-kill-buffer pbuffer))))) (process (condition-case err (let ((coding-system-for-read 'binary) @@ -1263,7 +1263,17 @@ If SEND-IF-FORCE, only send authinfo to the server if the "nntpd" pbuffer nntp-address nntp-port-number :type (cadr (assoc nntp-open-connection-function map)) :end-of-command "^\\([2345]\\|[.]\\).*\n" - :capability-command "HELP\r\n" + :capability-command + (lambda (greeting) + (if (and greeting + (string-match "Typhoon" greeting)) + ;; Certain versions of the Typhoon server + ;; doesn't understand the CAPABILITIES + ;; command, but includes the capability + ;; data in the HELP command instead. + "HELP\r\n" + ;; Use the correct command for everything else. + "CAPABILITIES\r\n")) :success "^3" :starttls-function (lambda (capabilities) diff --git a/lisp/gnus/nnvirtual.el b/lisp/gnus/nnvirtual.el index e1290a9c774..54c2f7be820 100644 --- a/lisp/gnus/nnvirtual.el +++ b/lisp/gnus/nnvirtual.el @@ -97,7 +97,7 @@ component group will show up when you enter the virtual group.") (if (stringp (car articles)) 'headers (let ((vbuf (nnheader-set-temp-buffer - (get-buffer-create " *virtual headers*"))) + (gnus-get-buffer-create " *virtual headers*"))) (carticles (nnvirtual-partition-sequence articles)) (sysname (system-name)) cgroup carticle article result prefix) diff --git a/lisp/gnus/spam.el b/lisp/gnus/spam.el index 5632bdaf250..96a7da2313c 100644 --- a/lisp/gnus/spam.el +++ b/lisp/gnus/spam.el @@ -579,7 +579,7 @@ This must be a list. For example, `(\"-C\" \"configfile\")'." (defcustom spam-spamassassin-positive-spam-flag-header "YES" "The regex on `spam-spamassassin-spam-flag-header' for positive spam identification." - :type 'string + :type 'regexp :group 'spam-spamassassin) (defcustom spam-spamassassin-spam-status-header "X-Spam-Status" diff --git a/lisp/help-fns.el b/lisp/help-fns.el index c7d0112cb61..b9536470631 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -647,8 +647,7 @@ FILE is the file where FUNCTION was probably defined." (setq place (list f pos)) (setq first version))))))))) (when first - (make-text-button first nil 'type 'help-news 'help-args place)) - first)) + (make-text-button first nil 'type 'help-news 'help-args place)))) (add-hook 'help-fns-describe-function-functions #'help-fns--mention-first-release) @@ -893,7 +892,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (output nil)) (if custom-version (setq output - (format "This %s was introduced, or its default value was changed, in\nversion %s of Emacs.\n" + (format " This %s was introduced, or its default value was changed, in\n version %s of Emacs.\n" type custom-version)) (when cpv (let* ((package (car-safe cpv)) @@ -904,7 +903,7 @@ If ANY-SYMBOL is non-nil, don't insist the symbol be bound." (emacsv (cdr (assoc version pkg-versions)))) (if (and package version) (setq output - (format (concat "This %s was introduced, or its default value was changed, in\nversion %s of the %s package" + (format (concat " This %s was introduced, or its default value was changed, in\n version %s of the %s package" (if emacsv (format " that is part of Emacs %s" emacsv)) ".\n") @@ -944,7 +943,7 @@ it is displayed along with the global value." (unless (buffer-live-p buffer) (setq buffer (current-buffer))) (unless (frame-live-p frame) (setq frame (selected-frame))) (if (not (symbolp variable)) - (message "You did not specify a variable") + (user-error "You didn't specify a variable") (save-excursion (let ((valvoid (not (with-current-buffer buffer (boundp variable)))) val val-start-pos locus) @@ -968,7 +967,7 @@ it is displayed along with the global value." " is a variable defined in `%s'.\n" (if (eq file-name 'C-source) "C source code" - (file-name-nondirectory file-name)))) + (help-fns-short-filename file-name)))) (with-current-buffer standard-output (save-excursion (re-search-backward (substitute-command-keys @@ -1125,8 +1124,8 @@ it is displayed along with the global value." ;; Note variable's version or package version. (let ((output (describe-variable-custom-version-info variable))) (when output - (terpri) - (terpri) + ;; (terpri) + ;; (terpri) (princ output))))) (add-hook 'help-fns-describe-variable-functions #'help-fns--var-safe-local) @@ -1352,7 +1351,7 @@ If FRAME is omitted or nil, use the selected frame." (setq file-name (find-lisp-object-file-name f 'defface)) (when file-name (princ (substitute-command-keys "Defined in `")) - (princ (file-name-nondirectory file-name)) + (princ (help-fns-short-filename file-name)) (princ (substitute-command-keys "'")) ;; Make a hyperlink to the library. (save-excursion @@ -1435,7 +1434,7 @@ current buffer and the selected frame, respectively." t nil nil (if found (symbol-name v-or-f))))) (list (if (equal val "") - v-or-f (intern val))))) + (or v-or-f "") (intern val))))) (if (not (symbolp symbol)) (user-error "You didn't specify a function or variable")) (unless (buffer-live-p buffer) (setq buffer (current-buffer))) @@ -1564,6 +1563,211 @@ BUFFER should be a buffer or a buffer name." (insert "\nThe parent category table is:") (describe-vector table 'help-describe-category-set)))))) +(defun help-fns-find-keymap-name (keymap) + "Find the name of the variable with value KEYMAP. +Return nil if KEYMAP is not a valid keymap, or if there is no +variable with value KEYMAP." + (when (keymapp keymap) + (let ((name (catch 'found-keymap + (mapatoms (lambda (symb) + (when (and (boundp symb) + (eq (symbol-value symb) keymap) + (not (eq symb 'keymap)) + (throw 'found-keymap symb))))) + nil))) + ;; Follow aliasing. + (or (ignore-errors (indirect-variable name)) name)))) + +(defun help-fns--most-relevant-active-keymap () + "Return the name of the most relevant active keymap. +The heuristic to determine which keymap is most likely to be +relevant to a user follows this order: + +1. 'keymap' text property at point +2. 'local-map' text property at point +3. the `current-local-map' + +This is used to set the default value for the interactive prompt +in `describe-keymap'. See also `Searching the Active Keymaps'." + (help-fns-find-keymap-name (or (get-char-property (point) 'keymap) + (if (get-text-property (point) 'local-map) + (get-char-property (point) 'local-map) + (current-local-map))))) + +;;;###autoload +(defun describe-keymap (keymap) + "Describe key bindings in KEYMAP. +When called interactively, prompt for a variable that has a +keymap value." + (interactive + (let* ((km (help-fns--most-relevant-active-keymap)) + (val (completing-read + (format "Keymap (default %s): " km) + obarray + (lambda (m) (and (boundp m) (keymapp (symbol-value m)))) + t nil 'keymap-name-history + (symbol-name km)))) + (unless (equal val "") + (setq km (intern val))) + (unless (and km (keymapp (symbol-value km))) + (user-error "Not a keymap: %s" km)) + (list km))) + (let (used-gentemp) + (unless (and (symbolp keymap) + (boundp keymap) + (keymapp (symbol-value keymap))) + (when (not (keymapp keymap)) + (if (symbolp keymap) + (error "Not a keymap variable: %S" keymap) + (error "Not a keymap"))) + (let ((sym nil)) + (unless sym + (setq sym (cl-gentemp "KEYMAP OBJECT (no variable) ")) + (setq used-gentemp t) + (set sym keymap)) + (setq keymap sym))) + ;; Follow aliasing. + (setq keymap (or (ignore-errors (indirect-variable keymap)) keymap)) + (help-setup-xref (list #'describe-keymap keymap) + (called-interactively-p 'interactive)) + (let* ((name (symbol-name keymap)) + (doc (documentation-property keymap 'variable-documentation)) + (file-name (find-lisp-object-file-name keymap 'defvar))) + (with-help-window (help-buffer) + (with-current-buffer standard-output + (unless used-gentemp + (princ (format-message "%S is a keymap variable" keymap)) + (if (not file-name) + (princ ".\n\n") + (princ (format-message + " defined in `%s'.\n\n" + (if (eq file-name 'C-source) + "C source code" + (help-fns-short-filename file-name)))) + (save-excursion + (re-search-backward (substitute-command-keys + "`\\([^`']+\\)'") + nil t) + (help-xref-button 1 'help-variable-def + keymap file-name)))) + (when (and (not (equal "" doc)) doc) + (princ "Documentation:\n") + (princ (format-message "%s\n\n" doc))) + ;; Use `insert' instead of `princ', so control chars (e.g. \377) + ;; insert correctly. + (insert (substitute-command-keys (concat "\\{" name "}")))))) + ;; Cleanup. + (when used-gentemp + (makunbound keymap)))) + +;;;###autoload +(defun describe-mode (&optional buffer) + "Display documentation of current major mode and minor modes. +A brief summary of the minor modes comes first, followed by the +major mode description. This is followed by detailed +descriptions of the minor modes, each on a separate page. + +For this to work correctly for a minor mode, the mode's indicator +variable \(listed in `minor-mode-alist') must also be a function +whose documentation describes the minor mode. + +If called from Lisp with a non-nil BUFFER argument, display +documentation for the major and minor modes of that buffer." + (interactive "@") + (unless buffer (setq buffer (current-buffer))) + (help-setup-xref (list #'describe-mode buffer) + (called-interactively-p 'interactive)) + ;; For the sake of help-do-xref and help-xref-go-back, + ;; don't switch buffers before calling `help-buffer'. + (with-help-window (help-buffer) + (with-current-buffer buffer + (let (minor-modes) + ;; Older packages do not register in minor-mode-list but only in + ;; minor-mode-alist. + (dolist (x minor-mode-alist) + (setq x (car x)) + (unless (memq x minor-mode-list) + (push x minor-mode-list))) + ;; Find enabled minor mode we will want to mention. + (dolist (mode minor-mode-list) + ;; Document a minor mode if it is listed in minor-mode-alist, + ;; non-nil, and has a function definition. + (let ((fmode (or (get mode :minor-mode-function) mode))) + (and (boundp mode) (symbol-value mode) + (fboundp fmode) + (let ((pretty-minor-mode + (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" + (symbol-name fmode)) + (capitalize + (substring (symbol-name fmode) + 0 (match-beginning 0))) + fmode))) + (push (list fmode pretty-minor-mode + (format-mode-line (assq mode minor-mode-alist))) + minor-modes))))) + ;; Narrowing is not a minor mode, but its indicator is part of + ;; mode-line-modes. + (when (buffer-narrowed-p) + (push '(narrow-to-region "Narrow" " Narrow") minor-modes)) + (setq minor-modes + (sort minor-modes + (lambda (a b) (string-lessp (cadr a) (cadr b))))) + (when minor-modes + (princ "Enabled minor modes:\n") + (make-local-variable 'help-button-cache) + (with-current-buffer standard-output + (dolist (mode minor-modes) + (let ((mode-function (nth 0 mode)) + (pretty-minor-mode (nth 1 mode)) + (indicator (nth 2 mode))) + (save-excursion + (goto-char (point-max)) + (princ "\n\f\n") + (push (point-marker) help-button-cache) + ;; Document the minor modes fully. + (insert-text-button + pretty-minor-mode 'type 'help-function + 'help-args (list mode-function) + 'button '(t)) + (princ (format " minor mode (%s):\n" + (if (zerop (length indicator)) + "no indicator" + (format "indicator%s" + indicator)))) + (princ (help-split-fundoc (documentation mode-function) + nil 'doc))) + (insert-button pretty-minor-mode + 'action (car help-button-cache) + 'follow-link t + 'help-echo "mouse-2, RET: show full information") + (newline))) + (forward-line -1) + (fill-paragraph nil) + (forward-line 1)) + + (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) + ;; Document the major mode. + (let ((mode mode-name)) + (with-current-buffer standard-output + (let ((start (point))) + (insert (format-mode-line mode nil nil buffer)) + (add-text-properties start (point) '(face bold))))) + (princ " mode") + (let* ((mode major-mode) + (file-name (find-lisp-object-file-name mode nil))) + (when file-name + (princ (format-message " defined in `%s'" + (help-fns-short-filename file-name))) + ;; Make a hyperlink to the library. + (with-current-buffer standard-output + (save-excursion + (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") + nil t) + (help-xref-button 1 'help-function-def mode file-name))))) + (princ ":\n") + (princ (help-split-fundoc (documentation major-mode) nil 'doc))))) + ;; For the sake of IELM and maybe others + nil) ;;; Replacements for old lib-src/ programs. Don't seem especially useful. diff --git a/lisp/help-mode.el b/lisp/help-mode.el index bae8281147a..9c2d1d72275 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -1,4 +1,4 @@ -;;; help-mode.el --- `help-mode' used by *Help* buffers +;;; help-mode.el --- `help-mode' used by *Help* buffers -*- lexical-binding: t; -*- ;; Copyright (C) 1985-1986, 1993-1994, 1998-2020 Free Software ;; Foundation, Inc. @@ -47,10 +47,10 @@ (define-key map "\C-c\C-c" 'help-follow-symbol) (define-key map "\r" 'help-follow) map) - "Keymap for help mode.") + "Keymap for Help mode.") (easy-menu-define help-mode-menu help-mode-map - "Menu for Help Mode." + "Menu for Help mode." '("Help-Mode" ["Show Help for Symbol" help-follow-symbol :help "Show the docs for the symbol at point"] @@ -327,13 +327,13 @@ Commands: ;;;###autoload (defun help-mode-setup () - "Enter Help Mode in the current buffer." + "Enter Help mode in the current buffer." (help-mode) (setq buffer-read-only nil)) ;;;###autoload (defun help-mode-finish () - "Finalize Help Mode setup in current buffer." + "Finalize Help mode setup in current buffer." (when (derived-mode-p 'help-mode) (setq buffer-read-only t) (help-make-xrefs (current-buffer)))) @@ -719,7 +719,8 @@ a proper [back] button." ;; There is a reference at point. Follow it. (let ((help-xref-following t)) (apply function (if (eq function 'info) - (append args (list (generate-new-buffer-name "*info*"))) args)))) + (append args (list (generate-new-buffer-name "*info*"))) + args)))) ;; The doc string is meant to explain what buttons do. (defun help-follow-mouse () diff --git a/lisp/help.el b/lisp/help.el index 0f1991e3185..b7d867eb70e 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -879,114 +879,6 @@ current buffer." (princ ", which is ") (describe-function-1 defn))))))) -(defun describe-mode (&optional buffer) - "Display documentation of current major mode and minor modes. -A brief summary of the minor modes comes first, followed by the -major mode description. This is followed by detailed -descriptions of the minor modes, each on a separate page. - -For this to work correctly for a minor mode, the mode's indicator -variable \(listed in `minor-mode-alist') must also be a function -whose documentation describes the minor mode. - -If called from Lisp with a non-nil BUFFER argument, display -documentation for the major and minor modes of that buffer." - (interactive "@") - (unless buffer (setq buffer (current-buffer))) - (help-setup-xref (list #'describe-mode buffer) - (called-interactively-p 'interactive)) - ;; For the sake of help-do-xref and help-xref-go-back, - ;; don't switch buffers before calling `help-buffer'. - (with-help-window (help-buffer) - (with-current-buffer buffer - (let (minor-modes) - ;; Older packages do not register in minor-mode-list but only in - ;; minor-mode-alist. - (dolist (x minor-mode-alist) - (setq x (car x)) - (unless (memq x minor-mode-list) - (push x minor-mode-list))) - ;; Find enabled minor mode we will want to mention. - (dolist (mode minor-mode-list) - ;; Document a minor mode if it is listed in minor-mode-alist, - ;; non-nil, and has a function definition. - (let ((fmode (or (get mode :minor-mode-function) mode))) - (and (boundp mode) (symbol-value mode) - (fboundp fmode) - (let ((pretty-minor-mode - (if (string-match "\\(\\(-minor\\)?-mode\\)?\\'" - (symbol-name fmode)) - (capitalize - (substring (symbol-name fmode) - 0 (match-beginning 0))) - fmode))) - (push (list fmode pretty-minor-mode - (format-mode-line (assq mode minor-mode-alist))) - minor-modes))))) - ;; Narrowing is not a minor mode, but its indicator is part of - ;; mode-line-modes. - (when (buffer-narrowed-p) - (push '(narrow-to-region "Narrow" " Narrow") minor-modes)) - (setq minor-modes - (sort minor-modes - (lambda (a b) (string-lessp (cadr a) (cadr b))))) - (when minor-modes - (princ "Enabled minor modes:\n") - (make-local-variable 'help-button-cache) - (with-current-buffer standard-output - (dolist (mode minor-modes) - (let ((mode-function (nth 0 mode)) - (pretty-minor-mode (nth 1 mode)) - (indicator (nth 2 mode))) - (save-excursion - (goto-char (point-max)) - (princ "\n\f\n") - (push (point-marker) help-button-cache) - ;; Document the minor modes fully. - (insert-text-button - pretty-minor-mode 'type 'help-function - 'help-args (list mode-function) - 'button '(t)) - (princ (format " minor mode (%s):\n" - (if (zerop (length indicator)) - "no indicator" - (format "indicator%s" - indicator)))) - (princ (help-split-fundoc (documentation mode-function) - nil 'doc))) - (insert-button pretty-minor-mode - 'action (car help-button-cache) - 'follow-link t - 'help-echo "mouse-2, RET: show full information") - (newline))) - (forward-line -1) - (fill-paragraph nil) - (forward-line 1)) - - (princ "\n(Information about these minor modes follows the major mode info.)\n\n")) - ;; Document the major mode. - (let ((mode mode-name)) - (with-current-buffer standard-output - (let ((start (point))) - (insert (format-mode-line mode nil nil buffer)) - (add-text-properties start (point) '(face bold))))) - (princ " mode") - (let* ((mode major-mode) - (file-name (find-lisp-object-file-name mode nil))) - (when file-name - (princ (format-message " defined in `%s'" - (file-name-nondirectory file-name))) - ;; Make a hyperlink to the library. - (with-current-buffer standard-output - (save-excursion - (re-search-backward (substitute-command-keys "`\\([^`']+\\)'") - nil t) - (help-xref-button 1 'help-function-def mode file-name))))) - (princ ":\n") - (princ (help-split-fundoc (documentation major-mode) nil 'doc))))) - ;; For the sake of IELM and maybe others - nil) - (defun search-forward-help-for-help () "Search forward \"help window\"." (interactive) diff --git a/lisp/hexl.el b/lisp/hexl.el index 2535d581db4..38eca77e260 100644 --- a/lisp/hexl.el +++ b/lisp/hexl.el @@ -367,8 +367,8 @@ You can use \\[hexl-find-file] to visit a file in Hexl mode. (add-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer nil t) ;; Set a callback function for eldoc. - (add-function :before-until (local 'eldoc-documentation-function) - #'hexl-print-current-point-info) + (add-hook 'eldoc-documentation-functions + #'hexl-print-current-point-info nil t) (eldoc-add-command-completions "hexl-") (eldoc-remove-command "hexl-save-buffer" "hexl-current-address") @@ -455,6 +455,8 @@ and edit the file in `hexl-mode'." ;; 2. reset change-major-mode-hook in case that `hexl-mode' ;; previously added hexl-maybe-dehexlify-buffer to it. (remove-hook 'change-major-mode-hook #'hexl-maybe-dehexlify-buffer t) + (remove-hook 'eldoc-documentation-functions + #'hexl-print-current-point-info t) (setq major-mode 'fundamental-mode) (hexl-mode))) @@ -513,7 +515,7 @@ Ask the user for confirmation." (message "Current address is %d/0x%08x" hexl-address hexl-address)) hexl-address)) -(defun hexl-print-current-point-info () +(defun hexl-print-current-point-info (&rest _ignored) "Return current hexl-address in string. This function is intended to be used as eldoc callback." (let ((addr (hexl-current-address))) @@ -701,10 +703,7 @@ With prefix arg N, puts point N bytes of the way from the true beginning." (defun hexl-end-of-line () "Goto end of line in Hexl mode." (interactive) - (hexl-goto-address (let ((address (logior (hexl-current-address) 15))) - (if (> address hexl-max-address) - (setq address hexl-max-address)) - address))) + (hexl-goto-address (min hexl-max-address (logior (hexl-current-address) 15)))) (defun hexl-scroll-down (arg) "Scroll hexl buffer window upward ARG lines; or near full window if no ARG." @@ -749,7 +748,7 @@ If there's no byte at the target address, move to the first or last line." "Go to end of 1KB boundary." (interactive) (hexl-goto-address - (max hexl-max-address (logior (hexl-current-address) 1023)))) + (min hexl-max-address (logior (hexl-current-address) 1023)))) (defun hexl-beginning-of-512b-page () "Go to beginning of 512 byte boundary." @@ -760,7 +759,7 @@ If there's no byte at the target address, move to the first or last line." "Go to end of 512 byte boundary." (interactive) (hexl-goto-address - (max hexl-max-address (logior (hexl-current-address) 511)))) + (min hexl-max-address (logior (hexl-current-address) 511)))) (defun hexl-quoted-insert (arg) "Read next input character and insert it. @@ -935,7 +934,7 @@ CH must be a unibyte character whose value is between 0 and 255." (goto-char ascii-position) (delete-char 1) (insert (hexl-printable-character ch)) - (or (eq address hexl-max-address) + (or (= address hexl-max-address) (setq address (1+ address))) (hexl-goto-address address) (if at-ascii-position diff --git a/lisp/hi-lock.el b/lisp/hi-lock.el index 0f685464cdd..a18310322ad 100644 --- a/lisp/hi-lock.el +++ b/lisp/hi-lock.el @@ -102,7 +102,7 @@ of functions `hi-lock-mode' and `hi-lock-find-patterns'." :type 'integer :group 'hi-lock) -(defcustom hi-lock-highlight-range 200000 +(defcustom hi-lock-highlight-range 2000000 "Size of area highlighted by hi-lock when font-lock not active. Font-lock is not active in buffers that do their own highlighting, such as the buffer created by `list-colors-display'. In those buffers @@ -233,6 +233,10 @@ Instead, each hi-lock command will cycle through the faces in "Patterns provided to hi-lock by user. Should not be changed.") (put 'hi-lock-interactive-patterns 'permanent-local t) +(defvar-local hi-lock-interactive-lighters nil + "Human-readable lighters for `hi-lock-interactive-patterns'.") +(put 'hi-lock-interactive-lighters 'permanent-local t) + (define-obsolete-variable-alias 'hi-lock-face-history 'hi-lock-face-defaults "23.1") (defvar hi-lock-face-defaults @@ -406,7 +410,8 @@ versions before 22 use the following in your init file: hi-lock-file-patterns) (when hi-lock-interactive-patterns (font-lock-remove-keywords nil hi-lock-interactive-patterns) - (setq hi-lock-interactive-patterns nil)) + (setq hi-lock-interactive-patterns nil + hi-lock-interactive-lighters nil)) (when hi-lock-file-patterns (font-lock-remove-keywords nil hi-lock-file-patterns) (setq hi-lock-file-patterns nil)) @@ -437,6 +442,9 @@ of text in those lines. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type." @@ -450,19 +458,29 @@ highlighting will not update as you type." (hi-lock-set-pattern ;; The \\(?:...\\) grouping construct ensures that a leading ^, +, * or ? ;; or a trailing $ in REGEXP will be interpreted correctly. - (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face)) + (concat "^.*\\(?:" regexp "\\).*\\(?:$\\)\n?") face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search))) ;;;###autoload (defalias 'highlight-regexp 'hi-lock-face-buffer) ;;;###autoload -(defun hi-lock-face-buffer (regexp &optional face subexp) +(defun hi-lock-face-buffer (regexp &optional face subexp lighter) "Set face of each match of REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. Limit face setting to the corresponding SUBEXP (interactively, the prefix argument) of REGEXP. If SUBEXP is omitted or nil, the entire REGEXP is highlighted. +LIGHTER is a human-readable string that can be used to select +a regexp to unhighlight by its name instead of selecting a possibly +complex regexp or closure. + +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. The Font Lock mode @@ -477,7 +495,12 @@ the major mode specifies support for Font Lock." current-prefix-arg)) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face subexp)) + (hi-lock-set-pattern + regexp face subexp lighter + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search) + search-spaces-regexp)) ;;;###autoload (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -487,9 +510,9 @@ the major mode specifies support for Font Lock." Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. -When called interactively, replace whitespace in user-provided -regexp with arbitrary whitespace, and make initial lower-case -letters case-insensitive, before highlighting with `hi-lock-set-pattern'. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. +Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the @@ -500,12 +523,16 @@ the major mode specifies support for Font Lock." (interactive (list (hi-lock-regexp-okay - (hi-lock-process-phrase - (read-regexp "Phrase to highlight" 'regexp-history-last))) + (read-regexp "Phrase to highlight" 'regexp-history-last)) (hi-lock-read-face-name))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face)) + (hi-lock-set-pattern + regexp face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search) + search-whitespace-regexp)) ;;;###autoload (defalias 'highlight-symbol-at-point 'hi-lock-face-symbol-at-point) @@ -516,6 +543,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting, unless you use a prefix argument. Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + This uses Font lock mode if it is enabled; otherwise it uses overlays, in which case the highlighting will not update as you type. The Font Lock mode is considered \"enabled\" in a buffer if its `major-mode' @@ -528,7 +558,11 @@ the major mode specifies support for Font Lock." (face (hi-lock-read-face-name))) (or (facep face) (setq face 'hi-yellow)) (unless hi-lock-mode (hi-lock-mode 1)) - (hi-lock-set-pattern regexp face))) + (hi-lock-set-pattern + regexp face nil nil + (if (and case-fold-search search-upper-case) + (isearch-no-upper-case-p regexp t) + case-fold-search)))) (defun hi-lock-keyword->face (keyword) (cadr (cadr (cadr keyword)))) ; Keyword looks like (REGEXP (0 'FACE) ...). @@ -542,13 +576,16 @@ the major mode specifies support for Font Lock." (let ((regexp (get-char-property (point) 'hi-lock-overlay-regexp))) (when regexp (push regexp regexps))) ;; With font-locking on, check if the cursor is on a highlighted text. - (let ((face-after (get-text-property (point) 'face)) - (face-before - (unless (bobp) (get-text-property (1- (point)) 'face))) - (faces (mapcar #'hi-lock-keyword->face - hi-lock-interactive-patterns))) - (unless (memq face-before faces) (setq face-before nil)) - (unless (memq face-after faces) (setq face-after nil)) + (let* ((faces-after (get-text-property (point) 'face)) + (faces-before + (unless (bobp) (get-text-property (1- (point)) 'face))) + ;; Use proper-list-p to handle faces like (foreground-color . "red3") + (faces-after (if (proper-list-p faces-after) faces-after (list faces-after))) + (faces-before (if (proper-list-p faces-before) faces-before (list faces-before))) + (faces (mapcar #'hi-lock-keyword->face + hi-lock-interactive-patterns)) + (face-after (seq-some (lambda (face) (car (memq face faces))) faces-after)) + (face-before (seq-some (lambda (face) (car (memq face faces))) faces-before))) (when (and face-before face-after (not (eq face-before face-after))) (setq face-before nil)) (when (or face-after face-before) @@ -566,7 +603,8 @@ the major mode specifies support for Font Lock." ;; highlighted text at point. Use this later in ;; during completing-read. (dolist (hi-lock-pattern hi-lock-interactive-patterns) - (let ((regexp (car hi-lock-pattern))) + (let ((regexp (or (car (rassq hi-lock-pattern hi-lock-interactive-lighters)) + (car hi-lock-pattern)))) (if (string-match regexp hi-text) (push regexp regexps))))))) regexps)) @@ -598,12 +636,15 @@ then remove all hi-lock highlighting." 'keymap (cons "Select Pattern to Unhighlight" (mapcar (lambda (pattern) - (list (car pattern) - (format - "%s (%s)" (car pattern) - (hi-lock-keyword->face pattern)) - (cons nil nil) - (car pattern))) + (let ((lighter + (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern)))) + (list lighter + (format + "%s (%s)" lighter + (hi-lock-keyword->face pattern)) + (cons nil nil) + lighter))) hi-lock-interactive-patterns)))) ;; If the user clicks outside the menu, meaning that they ;; change their mind, x-popup-menu returns nil, and @@ -614,17 +655,28 @@ then remove all hi-lock highlighting." (t ;; Un-highlighting triggered via keyboard action. (unless hi-lock-interactive-patterns - (error "No highlighting to remove")) + (user-error "No highlighting to remove")) ;; Infer the regexp to un-highlight based on cursor position. (let* ((defaults (or (hi-lock--regexps-at-point) - (mapcar #'car hi-lock-interactive-patterns)))) + (mapcar (lambda (pattern) + (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern))) + hi-lock-interactive-patterns)))) (list (completing-read (if (null defaults) "Regexp to unhighlight: " (format "Regexp to unhighlight (default %s): " (car defaults))) - hi-lock-interactive-patterns + (mapcar (lambda (pattern) + (cons (or (car (rassq pattern hi-lock-interactive-lighters)) + (car pattern)) + (cdr pattern))) + hi-lock-interactive-patterns) nil t nil nil defaults)))))) + + (when (assoc regexp hi-lock-interactive-lighters) + (setq regexp (cadr (assoc regexp hi-lock-interactive-lighters)))) + (dolist (keyword (if (eq regexp t) hi-lock-interactive-patterns (list (assoc regexp hi-lock-interactive-patterns)))) (when keyword @@ -641,7 +693,11 @@ then remove all hi-lock highlighting." (setq hi-lock-interactive-patterns (delq keyword hi-lock-interactive-patterns)) (remove-overlays - nil nil 'hi-lock-overlay-regexp (hi-lock--hashcons (car keyword))) + nil nil 'hi-lock-overlay-regexp + (or (car (rassq keyword hi-lock-interactive-lighters)) + (hi-lock--hashcons (car keyword)))) + (setq hi-lock-interactive-lighters + (rassq-delete-all keyword hi-lock-interactive-lighters)) (font-lock-flush)))) ;;;###autoload @@ -653,7 +709,7 @@ Interactively added patterns are those normally specified using be found in variable `hi-lock-interactive-patterns'." (interactive) (if (null hi-lock-interactive-patterns) - (error "There are no interactive patterns")) + (user-error "There are no interactive patterns")) (let ((beg (point))) (mapc (lambda (pattern) @@ -667,25 +723,6 @@ be found in variable `hi-lock-interactive-patterns'." ;; Implementation Functions -(defun hi-lock-process-phrase (phrase) - "Convert regexp PHRASE to a regexp that matches phrases. - -Blanks in PHRASE replaced by regexp that matches arbitrary whitespace -and initial lower-case letters made case insensitive." - (let ((mod-phrase nil)) - ;; FIXME fragile; better to just bind case-fold-search? (Bug#7161) - (setq mod-phrase - (replace-regexp-in-string - "\\(^\\|\\s-\\)\\([a-z]\\)" - (lambda (m) (format "%s[%s%s]" - (match-string 1 m) - (upcase (match-string 2 m)) - (match-string 2 m))) phrase)) - ;; FIXME fragile; better to use search-spaces-regexp? - (setq mod-phrase - (replace-regexp-in-string - "\\s-+" "[ \t\n]+" mod-phrase nil t)))) - (defun hi-lock-regexp-okay (regexp) "Return REGEXP if it appears suitable for a font-lock pattern. @@ -725,19 +762,27 @@ with completion and history." (add-to-list 'hi-lock-face-defaults face t)) (intern face))) -(defun hi-lock-set-pattern (regexp face &optional subexp) +(defun hi-lock-set-pattern (regexp face &optional subexp lighter case-fold spaces-regexp) "Highlight SUBEXP of REGEXP with face FACE. If omitted or nil, SUBEXP defaults to zero, i.e. the entire -REGEXP is highlighted." +REGEXP is highlighted. LIGHTER is a human-readable string to +display instead of a regexp. Non-nil CASE-FOLD ignores case. +SPACES-REGEXP is a regexp to substitute spaces in font-lock search." ;; Hashcons the regexp, so it can be passed to remove-overlays later. (setq regexp (hi-lock--hashcons regexp)) (setq subexp (or subexp 0)) - (let ((pattern (list regexp (list subexp (list 'quote face) 'prepend))) + (let ((pattern (list (lambda (limit) + (let ((case-fold-search case-fold) + (search-spaces-regexp spaces-regexp)) + (re-search-forward regexp limit t))) + (list subexp (list 'quote face) 'prepend))) (no-matches t)) ;; Refuse to highlight a text that is already highlighted. - (if (assoc regexp hi-lock-interactive-patterns) + (if (or (assoc regexp hi-lock-interactive-patterns) + (assoc (or lighter regexp) hi-lock-interactive-lighters)) (add-to-list 'hi-lock--unused-faces (face-name face)) (push pattern hi-lock-interactive-patterns) + (push (cons (or lighter regexp) pattern) hi-lock-interactive-lighters) (if (and font-lock-mode (font-lock-specified-p major-mode)) (progn (font-lock-add-keywords nil (list pattern) t) @@ -749,7 +794,9 @@ REGEXP is highlighted." (- range-min (max 0 (- range-max (point-max)))))) (search-end (min (point-max) - (+ range-max (max 0 (- (point-min) range-min)))))) + (+ range-max (max 0 (- (point-min) range-min))))) + (case-fold-search case-fold) + (search-spaces-regexp spaces-regexp)) (save-excursion (goto-char search-start) (while (re-search-forward regexp search-end t) @@ -757,13 +804,15 @@ REGEXP is highlighted." (let ((overlay (make-overlay (match-beginning subexp) (match-end subexp)))) (overlay-put overlay 'hi-lock-overlay t) - (overlay-put overlay 'hi-lock-overlay-regexp regexp) + (overlay-put overlay 'hi-lock-overlay-regexp (or lighter regexp)) (overlay-put overlay 'face face)) (goto-char (match-end 0))) (when no-matches (add-to-list 'hi-lock--unused-faces (face-name face)) (setq hi-lock-interactive-patterns - (cdr hi-lock-interactive-patterns))))))))) + (cdr hi-lock-interactive-patterns) + hi-lock-interactive-lighters + (cdr hi-lock-interactive-lighters))))))))) (defun hi-lock-set-file-patterns (patterns) "Replace file patterns list with PATTERNS and refontify." diff --git a/lisp/hippie-exp.el b/lisp/hippie-exp.el index 98edacd6ec0..ce5fc585c81 100644 --- a/lisp/hippie-exp.el +++ b/lisp/hippie-exp.el @@ -4,7 +4,7 @@ ;; Author: Anders Holst <aho@sans.kth.se> ;; Maintainer: emacs-devel@gnu.org -;; Version: 1.6 +;; Old-Version: 1.6 ;; Keywords: abbrev convenience ;; This file is part of GNU Emacs. diff --git a/lisp/htmlfontify.el b/lisp/htmlfontify.el index 08e52d63a26..6265537e885 100644 --- a/lisp/htmlfontify.el +++ b/lisp/htmlfontify.el @@ -11,9 +11,6 @@ ;; Created: 2002-01-05 ;; Description: htmlize a buffer/source tree with optional hyperlinks ;; URL: http://rtfm.etla.org/emacs/htmlfontify/ -;; Compatibility: Emacs23, Emacs22 -;; Incompatibility: Emacs19, Emacs20, Emacs21 -;; Last Updated: Thu 2009-11-19 01:31:21 +0000 ;; This file is part of GNU Emacs. @@ -136,8 +133,8 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file)) \"s section[eg- emacs / p4-blame]:\\nD source-dir: \\nD output-dir: \") (require \\='htmlfontify) (hfy-load-tags-cache srcdir) - (let ((hfy-page-header \\='rtfm-build-page-header) - (hfy-page-footer \\='rtfm-build-page-footer) + (let ((hfy-page-header #\\='rtfm-build-page-header) + (hfy-page-footer #\\='rtfm-build-page-footer) (rtfm-section section) (hfy-index-file \"index\")) (htmlfontify-run-etags srcdir) @@ -151,7 +148,7 @@ main-content <=MAIN_CONTENT;\\n\" rtfm-section file style rtfm-section file)) :link '(info-link "(htmlfontify) Customization") :prefix "hfy-") -(defcustom hfy-page-header 'hfy-default-header +(defcustom hfy-page-header #'hfy-default-header "Function called to build the header of the HTML source. This is called with two arguments (the filename relative to the top level source directory being etag'd and fontified), and a string containing @@ -159,7 +156,6 @@ the <style>...</style> text to embed in the document. It should return a string that will be used as the header for the htmlfontified version of the source file.\n See also `hfy-page-footer'." - :group 'htmlfontify ;; FIXME: Why place such a :tag everywhere? Isn't it imposing your ;; own Custom preference on your users? --Stef :tag "page-header" @@ -170,66 +166,57 @@ See also `hfy-page-footer'." If non-nil, the index is split on the first letter of each tag. Useful when the index would otherwise be large and take a long time to render or be difficult to navigate." - :group 'htmlfontify :tag "split-index" :type '(boolean)) -(defcustom hfy-page-footer 'hfy-default-footer +(defcustom hfy-page-footer #'hfy-default-footer "As `hfy-page-header', but generates the output footer. It takes only one argument, the filename." - :group 'htmlfontify :tag "page-footer" :type '(function)) (defcustom hfy-extn ".html" "File extension used for output files." - :group 'htmlfontify :tag "extension" :type '(string)) (defcustom hfy-src-doc-link-style "text-decoration: underline;" "String to add to the `<style> a' variant of an htmlfontify CSS class." - :group 'htmlfontify :tag "src-doc-link-style" :type '(string)) (defcustom hfy-src-doc-link-unstyle " text-decoration: none;" "Regex to remove from the `<style> a' variant of an htmlfontify CSS class." - :group 'htmlfontify :tag "src-doc-link-unstyle" - :type '(string)) + :type '(regexp)) (defcustom hfy-link-extn nil "File extension used for href links. Useful where the htmlfontify output files are going to be processed again, with a resulting change in file extension. If nil, then any code using this should fall back to `hfy-extn'." - :group 'htmlfontify :tag "link-extension" :type '(choice string (const nil))) -(defcustom hfy-link-style-fun 'hfy-link-style-string +(defcustom hfy-link-style-fun #'hfy-link-style-string "Function to customize the appearance of hyperlinks. Set this to a function, which will be called with one argument \(a \"{ foo: bar; ...}\" CSS style-string) - it should return a copy of its argument, altered so as to make any changes you want made for text which is a hyperlink, in addition to being in the class to which that style would normally be applied." - :group 'htmlfontify :tag "link-style-function" :type '(function)) (defcustom hfy-index-file "hfy-index" "Name (sans extension) of the tag definition index file produced during fontification-and-hyperlinking." - :group 'htmlfontify :tag "index-file" :type '(string)) (defcustom hfy-instance-file "hfy-instance" "Name (sans extension) of the tag usage index file produced during fontification-and-hyperlinking." - :group 'htmlfontify :tag "instance-file" :type '(string)) @@ -237,25 +224,13 @@ fontification-and-hyperlinking." "Regex to match (with a single back-reference per match) strings in HTML which should be quoted with `hfy-html-quote' (and `hfy-html-quote-map') to make them safe." - :group 'htmlfontify :tag "html-quote-regex" :type '(regexp)) -(define-obsolete-variable-alias 'hfy-init-kludge-hooks 'hfy-init-kludge-hook - "23.2") -(defcustom hfy-init-kludge-hook '(hfy-kludge-cperl-mode) - "List of functions to call when starting `htmlfontify-buffer' to do any -kludging necessary to get highlighting modes to behave as you want, even -when not running under a window system." - :group 'htmlfontify - :tag "init-kludge-hooks" - :type '(hook)) - (define-obsolete-variable-alias 'hfy-post-html-hooks 'hfy-post-html-hook "24.3") (defcustom hfy-post-html-hook nil "List of functions to call after creating and filling the HTML buffer. These functions will be called with the HTML buffer as the current buffer." - :group 'htmlfontify :tag "post-html-hooks" :options '(set-auto-mode) :type '(hook)) @@ -267,7 +242,6 @@ potentially non-current face information doesn't necessarily work for `default').\n Example: I customize this to:\n \((t :background \"black\" :foreground \"white\" :family \"misc-fixed\"))" - :group 'htmlfontify :tag "default-face-definition" :type '(alist)) @@ -281,7 +255,6 @@ in order, to:\n 1 - The tag 2 - The line 3 - The char (point) at which the tag occurs." - :group 'htmlfontify :tag "etag-regex" :type '(regexp)) @@ -290,7 +263,6 @@ in order, to:\n ("&" "&" ) (">" ">" )) "Alist of char -> entity mappings used to make the text HTML-safe." - :group 'htmlfontify :tag "html-quote-map" :type '(alist :key-type (string))) (defconst hfy-e2x-etags-cmd "for src in `find . -type f`; @@ -332,7 +304,6 @@ done;") hfy-etags-cmd-alist-default "Alist of possible shell commands that will generate etags output that `htmlfontify' can use. `%s' will be replaced by `hfy-etags-bin'." - :group 'htmlfontify :tag "etags-cmd-alist" :type '(alist :key-type (string) :value-type (string))) @@ -340,13 +311,11 @@ done;") "Location of etags binary (we begin by assuming it's in your path).\n Note that if etags is not in your path, you will need to alter the shell commands in `hfy-etags-cmd-alist'." - :group 'htmlfontify :tag "etags-bin" :type '(file)) (defcustom hfy-shell-file-name "/bin/sh" "Shell (Bourne or compatible) to invoke for complex shell operations." - :group 'htmlfontify :tag "shell-file-name" :type '(file)) @@ -358,7 +327,6 @@ commands in `hfy-etags-cmd-alist'." point-entered point-left) "Properties to omit when copying a fontified buffer for HTML transformation." - :group 'htmlfontify :tag "ignored-properties" :type '(repeat symbol)) @@ -387,7 +355,6 @@ file for the whole source tree from there on down. The command should emit the etags output on stdout.\n Two canned commands are provided - they drive Emacs's etags and exuberant-ctags' etags respectively." - :group 'htmlfontify :tag "etags-command" :type (let ((clist (list '(string)))) (dolist (C hfy-etags-cmd-alist) @@ -398,14 +365,12 @@ exuberant-ctags' etags respectively." "Command to run with the name of a file, to see whether it is a text file or not. The command should emit a string containing the word `text' if the file is a text file, and a string not containing `text' otherwise." - :group 'htmlfontify :tag "istext-command" :type '(string)) (defcustom hfy-find-cmd "find . -type f \\! -name \\*~ \\! -name \\*.flc \\! -path \\*/CVS/\\*" "Find command used to harvest a list of files to attempt to fontify." - :group 'htmlfontify :tag "find-command" :type '(string)) @@ -434,7 +399,6 @@ of these values in the specification key constitutes a match, eg:\n ((type tty) (class color))\n and so on." :type '(alist :key-type (symbol) :value-type (symbol)) - :group 'htmlfontify :tag "display-class" :options '((type (choice (const :tag "X11" x-toolkit) (const :tag "Terminal" tty ) @@ -481,7 +445,6 @@ which can never slow you down, but may result in incomplete fontification." (const :tag "div-wrapper" div-wrapper ) (const :tag "keep-overlays" keep-overlays ) (const :tag "body-text-only" body-text-only )) - :group 'htmlfontify :tag "optimizations") (defvar hfy-tags-cache nil @@ -599,13 +562,14 @@ If a window system is unavailable, calls `hfy-fallback-color-values'." (x-color-values color)) ;; blarg - tty colors are no good - go fetch some X colors: (hfy-fallback-color-values color)))) -(define-obsolete-function-alias 'hfy-colour-vals 'hfy-color-vals "27.1") +(define-obsolete-function-alias 'hfy-colour-vals #'hfy-color-vals "27.1") (defvar hfy-cperl-mode-kludged-p nil) (defun hfy-kludge-cperl-mode () "CPerl mode does its damnedest not to do some of its fontification when not in a windowing system - try to trick it..." + (declare (obsolete nil "28.1")) (if (not hfy-cperl-mode-kludged-p) (progn (if (not window-system) (let ((window-system 'htmlfontify)) @@ -728,7 +692,7 @@ STYLE is the inline CSS stylesheet (or tag referring to an external sheet)." --> </script> </head> <body onload=\"stripe('index'); return true;\">\n" - (mapconcat 'hfy-html-quote (mapcar 'char-to-string file) "") style)) + (mapconcat #'hfy-html-quote (mapcar #'char-to-string file) "") style)) (defun hfy-default-footer (_file) "Default value for `hfy-page-footer'. @@ -766,24 +730,24 @@ may happen." (let ((white (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals "white"))) (rgb16 (mapcar (lambda (I) (float (1+ I))) (hfy-color-vals color)))) (if rgb16 - ;;(apply 'format "rgb(%d, %d, %d)" + ;;(apply #'format "rgb(%d, %d, %d)" ;; Use #rrggbb instead, it is smaller - (apply 'format "#%02x%02x%02x" + (apply #'format "#%02x%02x%02x" (mapcar (lambda (X) (* (/ (nth X rgb16) - (nth X white)) 255)) + (nth X white)) + 255)) '(0 1 2)))))) (defun hfy-family (family) (list (cons "font-family" family))) (defun hfy-bgcol (color) (list (cons "background" (hfy-triplet color)))) (defun hfy-color (color) (list (cons "color" (hfy-triplet color)))) -(define-obsolete-function-alias 'hfy-colour 'hfy-color "27.1") +(define-obsolete-function-alias 'hfy-colour #'hfy-color "27.1") (defun hfy-width (width) (list (cons "font-stretch" (symbol-name width)))) (defcustom hfy-font-zoom 1.05 "Font scaling from Emacs to HTML." - :type 'float - :group 'htmlfontify) + :type 'float) (defun hfy-size (height) "Derive a CSS font-size specifier from an Emacs font :height attribute HEIGHT. @@ -1062,7 +1026,7 @@ haven't encountered them yet. Returns a `hfy-style-assoc'." (when (string-match "pt" (cdr css)) (setq x t))) (setq r (nconc r (list css))))) ;;(message "r: %S" r) - (setq n (apply '* m)) + (setq n (apply #'* m)) (nconc r (hfy-size (if x (round n) (* n 1.0)))) )) (defun hfy-face-resolve-face (fn) @@ -1152,9 +1116,9 @@ See also `hfy-face-to-css'." (push (car E) seen) (format " %s: %s; " (car E) (cdr E))))) css-list))) - (cons (hfy-css-name fn) (format "{%s}" (apply 'concat css-text)))) ) + (cons (hfy-css-name fn) (format "{%s}" (apply #'concat css-text)))) ) -(defvar hfy-face-to-css 'hfy-face-to-css-default +(defvar hfy-face-to-css #'hfy-face-to-css-default "Handler for mapping faces to styles. The signature of the handler is of the form \(lambda (FN) ...). FN is a font or `defface' specification (cf @@ -1510,7 +1474,7 @@ Uses `hfy-link-style-fun' to do this." ;; Fix-me: Add handling of page breaks here + scan for ^L ;; where appropriate. (format "body, pre %s\n" (cddr (assq 'default css))) - (apply 'concat + (apply #'concat (mapcar (lambda (style) (format @@ -1611,7 +1575,7 @@ Insert \"</span>\". See `hfy-end-span-handler' for more information." (insert "</span>")) -(defvar hfy-begin-span-handler 'hfy-begin-span +(defvar hfy-begin-span-handler #'hfy-begin-span "Handler to begin a span of text. The signature of the handler is \(lambda (STYLE TEXT-BLOCK TEXT-ID TEXT-BEGINS-BLOCK-P) ...). The handler must insert @@ -1640,7 +1604,7 @@ behavior. The default handler is `hfy-begin-span'.") -(defvar hfy-end-span-handler 'hfy-end-span +(defvar hfy-end-span-handler #'hfy-end-span "Handler to end a span of text. The signature of the handler is \(lambda () ...). The handler must insert appropriate tags to end a span of text. @@ -1821,33 +1785,7 @@ fontified. This is a simple convenience wrapper around (htmlfontify-buffer) (buffer-string)))) -(defun hfy-force-fontification () - "Try to force font-locking even when it is optimized away." - (run-hooks 'hfy-init-kludge-hook) - (eval-and-compile (require 'font-lock)) - (if (boundp 'font-lock-cache-position) - (or font-lock-cache-position - (setq font-lock-cache-position (make-marker)))) - (cond - (noninteractive - (message "hfy batch mode (%s:%S)" - (or (buffer-file-name) (buffer-name)) major-mode) - (if (fboundp 'font-lock-ensure) ; Emacs >= 25.1 - (font-lock-ensure) - (when font-lock-defaults - ; Silence "interactive use only" warning on Emacs >= 25.1. - (with-no-warnings (font-lock-fontify-buffer))))) - ((and (fboundp #'jit-lock-fontify-now) - (bound-and-true-p jit-lock-mode)) - (message "hfy jit-lock mode (%S %S)" window-system major-mode) - (jit-lock-fontify-now)) - (t - (message "hfy interactive mode (%S %S)" window-system major-mode) - ;; If jit-lock is not in use, then the buffer is already fontified! - ;; (when (and font-lock-defaults - ;; font-lock-mode) - ;; (font-lock-fontify-region (point-min) (point-max) nil)) - ))) +(define-obsolete-function-alias 'hfy-force-fontification #'font-lock-ensure "28.1") ;;;###autoload (defun htmlfontify-buffer (&optional srcdir file) @@ -1875,8 +1813,7 @@ hyperlinks as appropriate." (setq file (match-string 1 file)))) ) (if (not (hfy-opt 'skip-refontification)) - (save-excursion ;; Keep region - (hfy-force-fontification))) + (font-lock-ensure)) (if (called-interactively-p 'any) ;; display the buffer in interactive mode: (switch-to-buffer (hfy-fontify-buffer srcdir file)) (hfy-fontify-buffer srcdir file))) @@ -1934,7 +1871,7 @@ adding an extension of `hfy-extn'. Fontification is actually done by ;; FIXME: Shouldn't this use expand-file-name? --Stef (setq target (concat dstdir "/" file)) (hfy-make-directory (hfy-dirname target)) - (if (not (hfy-opt 'skip-refontification)) (hfy-force-fontification)) + (if (not (hfy-opt 'skip-refontification)) (font-lock-ensure)) (if (or (hfy-fontified-p) (hfy-text-p srcdir file)) (progn (setq html (hfy-fontify-buffer srcdir file)) (set-buffer html) @@ -2392,7 +2329,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." ;; (custom-save-delete 'hfy-set-hooks) ;; (let ((standard-output (current-buffer))) ;; (princ "(hfy-set-hooks\n;;auto-generated, only one copy allowed\n") -;; (mapatoms 'hfy-pp-hook) +;; (mapatoms #'hfy-pp-hook) ;; (insert "\n)") ;; ) ;; ) @@ -2419,7 +2356,7 @@ You may also want to set `hfy-page-header' and `hfy-page-footer'." ;; FIXME: This saving&restoring of global customization ;; variables can interfere with other customization settings for ;; those vars (in .emacs or in Customize). - (mapc 'hfy-save-initvar + (mapc #'hfy-save-initvar '(auto-mode-alist interpreter-mode-alist)) (princ ")\n") (indent-region start-pos (point) nil)) diff --git a/lisp/ibuffer.el b/lisp/ibuffer.el index 851b25f9ec0..c9a748830c1 100644 --- a/lisp/ibuffer.el +++ b/lisp/ibuffer.el @@ -339,6 +339,8 @@ directory, like `default-directory'." (defcustom ibuffer-load-hook nil "Hook run when Ibuffer is loaded." :type 'hook) +(make-obsolete-variable 'ibuffer-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom ibuffer-marked-face 'warning "Face used for displaying marked buffers." diff --git a/lisp/ido.el b/lisp/ido.el index 7198649e5a5..e834916a6da 100644 --- a/lisp/ido.el +++ b/lisp/ido.el @@ -243,7 +243,7 @@ ;; current frame are put at the end of the list. A hook exists to ;; allow other functions to order the list. For example, if you add: ;; -;; (add-hook 'ido-make-buffer-list-hook 'ido-summary-buffers-to-end) +;; (add-hook 'ido-make-buffer-list-hook #'ido-summary-buffers-to-end) ;; ;; then all files matching "Summary" are moved to the end of the ;; list. (I find this handy for keeping the INBOX Summary and so on @@ -355,8 +355,8 @@ The following values are possible: Setting this variable directly does not take effect; use either \\[customize] or the function `ido-mode'." :set #'(lambda (_symbol value) - (ido-mode value)) - :initialize 'custom-initialize-default + (ido-mode (or value 0))) + :initialize #'custom-initialize-default :require 'ido :link '(emacs-commentary-link "ido.el") :set-after '(ido-save-directory-list-file @@ -366,13 +366,11 @@ use either \\[customize] or the function `ido-mode'." :type '(choice (const :tag "Turn on only buffer" buffer) (const :tag "Turn on only file" file) (const :tag "Turn on both buffer and file" both) - (const :tag "Switch off all" nil)) - :group 'ido) + (const :tag "Switch off all" nil))) (defcustom ido-case-fold case-fold-search "Non-nil if searching of buffer and file names should ignore case." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-ignore-buffers '("\\` ") @@ -380,8 +378,7 @@ use either \\[customize] or the function `ido-mode'." For example, traditional behavior is not to list buffers whose names begin with a space, for which the regexp is `\\\\=` '. See the source file for example functions that filter buffer names." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-files '("\\`CVS/" "\\`#" "\\`.#" "\\`\\.\\./" "\\`\\./") @@ -389,19 +386,16 @@ example functions that filter buffer names." For example, traditional behavior is not to list files whose names begin with a #, for which the regexp is `\\\\=`#'. See the source file for example functions that filter filenames." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-extensions t "Non-nil means ignore files in `completion-ignored-extensions' list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-show-dot-for-dired nil "Non-nil means to always put . as the first item in file name lists. This allows the current directory to be opened immediately with `dired'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-file-extensions-order nil "List of file extensions specifying preferred order of file selections. @@ -409,21 +403,18 @@ Each element is either a string with `.' as the first char, an empty string matching files without extension, or t which is the default order for files with an unlisted file extension." :type '(repeat (choice string - (const :tag "Default order" t))) - :group 'ido) + (const :tag "Default order" t)))) (defcustom ido-ignore-directories '("\\`CVS/" "\\`\\.\\./" "\\`\\./") "List of regexps or functions matching sub-directory names to ignore." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) (defcustom ido-ignore-directories-merge nil "List of regexps or functions matching directory names to ignore during merge. Directory names matched by one of the regexps in this list are not inserted in merged file and directory lists." - :type '(repeat (choice regexp function)) - :group 'ido) + :type '(repeat (choice regexp function))) ;; Examples for setting the value of ido-ignore-buffers ;;(defun ido-ignore-c-mode (name) @@ -453,8 +444,7 @@ Possible values: (const :tag "Display (no select) in other window" display) (const :tag "Visit in other frame" other-frame) (const :tag "Ask to visit in other frame" maybe-frame) - (const :tag "Raise frame if already visited" raise-frame)) - :group 'ido) + (const :tag "Raise frame if already visited" raise-frame))) (defcustom ido-default-buffer-method 'raise-frame "How to switch to new buffer when using `ido-switch-buffer'. @@ -464,38 +454,33 @@ See `ido-default-file-method' for details." (const :tag "Display (no select) in other window" display) (const :tag "Show in other frame" other-frame) (const :tag "Ask to show in other frame" maybe-frame) - (const :tag "Raise frame if already shown" raise-frame)) - :group 'ido) + (const :tag "Raise frame if already shown" raise-frame))) (defcustom ido-enable-flex-matching nil "Non-nil means that Ido will do flexible string matching. Flexible matching means that if the entered string does not match any item, any item containing the entered characters in the given sequence will match." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-regexp nil "Non-nil means that Ido will do regexp matching. Value can be toggled within Ido using `ido-toggle-regexp'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-prefix nil "Non-nil means only match if the entered text is a prefix of file name. This behavior is like the standard Emacs completion. If nil, match if the entered text is an arbitrary substring. Value can be toggled within Ido using `ido-toggle-prefix'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-dot-prefix nil "Non-nil means to match leading dot as prefix. I.e. hidden files and buffers will match only if you type a dot as first char even if `ido-enable-prefix' is nil." - :type 'boolean - :group 'ido) + :type 'boolean) ;; See https://debbugs.gnu.org/2042 for more info. (defcustom ido-buffer-disable-smart-matches t @@ -506,30 +491,29 @@ By default, Ido arranges matches in the following order: which can get in the way for buffer switching." :version "24.3" - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-confirm-unique-completion nil "Non-nil means that even a unique completion must be confirmed. This means that \\[ido-complete] must always be followed by \\[ido-exit-minibuffer] even when there is only one unique completion." - :type 'boolean - :group 'ido) + :type 'boolean) -(defcustom ido-cannot-complete-command 'ido-completion-help +(defcustom ido-cannot-complete-command #'ido-completion-auto-help "Command run when `ido-complete' can't complete any more. The most useful values are `ido-completion-help', which pops up a -window with completion alternatives, or `ido-next-match' or -`ido-prev-match', which cycle the buffer list." - :type 'function - :group 'ido) +window with completion alternatives; `ido-completion-auto-help', +which does the same but respects the value of +`completion-auto-help'; and `ido-next-match' or `ido-prev-match', +which cycle the buffer list." + :version "28.1" + :type 'function) (defcustom ido-record-commands t "Non-nil means that Ido will record commands in command history. Note that the non-Ido equivalent command is recorded." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-max-prospects 12 "Upper limit of the prospect list if non-zero. @@ -537,8 +521,7 @@ Zero means no limit for the prospect list. For a long list of prospects, building the full list for the minibuffer can take a non-negligible amount of time; setting this variable reduces that time." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-max-file-prompt-width 0.35 "Upper limit of the prompt string. @@ -550,8 +533,7 @@ the frame width." (integer :tag "Characters" :value 20) (restricted-sexp :tag "Fraction of frame width" :value 0.35 - :match-alternatives (ido-fractionp))) - :group 'ido) + :match-alternatives (ido-fractionp)))) (defcustom ido-max-window-height nil "Non-nil specifies a value to override `max-mini-window-height'." @@ -561,28 +543,24 @@ the frame width." (restricted-sexp :tag "Fraction of window height" :value 0.25 - :match-alternatives (ido-fractionp))) - :group 'ido) + :match-alternatives (ido-fractionp)))) (defcustom ido-enable-last-directory-history t "Non-nil means that Ido will remember latest selected directory names. See `ido-last-directory-list' and `ido-save-directory-list-file'." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-max-work-directory-list 50 "Maximum number of working directories to record. This is the list of directories where files have most recently been opened. See `ido-work-directory-list' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-work-directory-list-ignore-regexps nil "List of regexps matching directories which should not be recorded. Directory names matched by one of the regexps in this list are not inserted in the `ido-work-directory-list' list." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defcustom ido-use-filename-at-point nil @@ -592,52 +570,44 @@ If found, use that as the starting point for filename selection." :type '(choice (const :tag "Disabled" nil) (const :tag "Guess filename" guess) - (other :tag "Use literal filename" t)) - :group 'ido) + (other :tag "Use literal filename" t))) (defcustom ido-use-url-at-point nil "Non-nil means that ido shall look for a URL at point. If found, call `find-file-at-point' to visit it." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enable-tramp-completion t "Non-nil means that Ido shall perform tramp method and server name completion. A tramp file name uses the following syntax: /method:user@host:filename." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-record-ftp-work-directories t "Non-nil means record FTP file names in the work directory list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-merge-ftp-work-directories nil "If nil, merging ignores FTP file names in the work directory list." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-cache-ftp-work-directory-time 1.0 "Maximum time to cache contents of an FTP directory (in hours). \\<ido-file-completion-map> Use \\[ido-reread-directory] in prompt to refresh list. If zero, FTP directories are not cached." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-slow-ftp-hosts nil "List of slow FTP hosts where Ido prompting should not be used. If an FTP host is on this list, Ido automatically switches to the non-Ido equivalent function, e.g. `find-file' rather than `ido-find-file'." - :type '(repeat string) - :group 'ido) + :type '(repeat string)) (defcustom ido-slow-ftp-host-regexps nil "List of regexps matching slow FTP hosts (see `ido-slow-ftp-hosts')." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defvar ido-unc-hosts-cache t "Cached value from the function `ido-unc-hosts'.") @@ -652,66 +622,56 @@ hosts on first use of UNC path." (function :tag "Your own function")) :set #'(lambda (symbol value) (set symbol value) - (setq ido-unc-hosts-cache t)) - :group 'ido) + (setq ido-unc-hosts-cache t))) (defcustom ido-downcase-unc-hosts t "Non-nil if UNC host names should be downcased." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-ignore-unc-host-regexps nil "List of regexps matching UNC hosts to ignore. Case is ignored if `ido-downcase-unc-hosts' is set." - :type '(repeat regexp) - :group 'ido) + :type '(repeat regexp)) (defcustom ido-cache-unc-host-shares-time 8.0 "Maximum time to cache shares of an UNC host (in hours). \\<ido-file-completion-map> Use \\[ido-reread-directory] in prompt to refresh list. If zero, UNC host shares are not cached." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-max-work-file-list 10 "Maximum number of names of recently opened files to record. This is the list of the file names (sans directory) which have most recently been opened. See `ido-work-file-list' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-work-directory-match-only t "Non-nil means to skip non-matching directories in the directory history. When some text is already entered at the `ido-find-file' prompt, using \\[ido-prev-work-directory] or \\[ido-next-work-directory] will skip directories without any matching entries." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-auto-merge-work-directories-length 0 "Automatically switch to merged work directories during file name input. The value is number of characters to type before switching to merged mode. If zero, the switch happens when no matches are found in the current directory. Automatic merging is disabled if the value is negative." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-auto-merge-delay-time 0.70 "Delay in seconds to wait for more input before doing auto merge." - :type 'number - :group 'ido) + :type 'number) (defcustom ido-auto-merge-inhibit-characters-regexp "[][*?~]" "Regexp matching characters which should inhibit automatic merging. When a (partial) file name matches this regexp, merging is inhibited." - :type 'regexp - :group 'ido) + :type 'regexp) (defcustom ido-merged-indicator "^" "The string appended to first choice if it has multiple directory choices." - :type 'string - :group 'ido) + :type 'string) (defcustom ido-max-dir-file-cache 100 "Maximum number of working directories to be cached. @@ -723,8 +683,7 @@ modification times, so you may choose to disable caching on such systems, or explicitly refresh the cache contents using the command `ido-reread-directory' command (\\[ido-reread-directory]) in the minibuffer. See also `ido-dir-file-cache' and `ido-save-directory-list-file'." - :type 'integer - :group 'ido) + :type 'integer) (defcustom ido-max-directory-size nil "Maximum size (in bytes) for directories to use Ido completion. @@ -732,21 +691,18 @@ See also `ido-dir-file-cache' and `ido-save-directory-list-file'." If you enter a directory with a size larger than this size, Ido will not provide the normal completion. To show the completions, use \\[ido-toggle-ignore]." :type '(choice (const :tag "No limit" nil) - (integer :tag "Size in bytes" 30000)) - :group 'ido) + (integer :tag "Size in bytes" 30000))) (defcustom ido-big-directories nil "List of directory pattern strings that should be considered big. Ido won't attempt to list the contents of directories matching any of these regular expressions when completing file names." :type '(repeat regexp) - :group 'ido :version "27.1") (defcustom ido-rotate-file-list-default nil "Non-nil means that Ido will always rotate file list to get default in front." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-enter-matching-directory 'only "Additional methods to enter sub-directory of first/only matching item. @@ -758,8 +714,7 @@ matching item, even without typing a slash." :type '(choice (const :tag "Never" nil) (const :tag "Slash enters first directory" first) (const :tag "Slash enters first and only directory" only) - (other :tag "Always enter unique directory" t)) - :group 'ido) + (other :tag "Always enter unique directory" t))) (defcustom ido-create-new-buffer 'prompt "Specify whether a new buffer is created if no buffer matches substring. @@ -767,21 +722,18 @@ Choices are `always' to create new buffers unconditionally, `prompt' to ask user whether to create buffer, or `never' to never create new buffer." :type '(choice (const always) (const prompt) - (const never)) - :group 'ido) + (const never))) (defcustom ido-setup-hook nil "Hook run after the Ido variables and keymap have been setup. The dynamic variable `ido-cur-item' contains the current type of item that is read by Ido; possible values are file, dir, buffer, and list. Additional keys can be defined in `ido-completion-map'." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-separator nil "String used by Ido to separate the alternatives in the minibuffer." - :type '(choice string (const nil)) - :group 'ido) + :type '(choice string (const nil))) (make-obsolete-variable 'ido-separator "set 3rd element of `ido-decorations' instead." nil) @@ -802,8 +754,7 @@ can be completed using TAB, 11th element is displayed to confirm creating new file or buffer. 12th and 13th elements (if present) are used as brackets around the sole remaining completion. If absent, elements 5 and 6 are used instead." - :type '(repeat string) - :group 'ido) + :type '(repeat string)) (defcustom ido-use-virtual-buffers nil "If non-nil, refer to past (\"virtual\") buffers as well as existing ones. @@ -827,71 +778,60 @@ enabled if this variable is configured to a non-nil value." :version "24.1" :type '(choice (const :tag "Always" t) (const :tag "Automatic" auto) - (const :tag "Never" nil)) - :group 'ido) + (const :tag "Never" nil))) (defcustom ido-use-faces t "Non-nil means use Ido faces to highlighting first match, only match and subdirs in the alternatives." - :type 'boolean - :group 'ido) + :type 'boolean) (defface ido-first-match '((t :weight bold)) - "Face used by Ido for highlighting first match." - :group 'ido) + "Face used by Ido for highlighting first match.") (defface ido-only-match '((((class color)) :foreground "ForestGreen") (t :slant italic)) - "Face used by Ido for highlighting only match." - :group 'ido) + "Face used by Ido for highlighting only match.") (defface ido-subdir '((((min-colors 88) (class color)) :foreground "red1") (((class color)) :foreground "red") (t :underline t)) - "Face used by Ido for highlighting subdirs in the alternatives." - :group 'ido) + "Face used by Ido for highlighting subdirs in the alternatives.") (defface ido-virtual '((t :inherit font-lock-builtin-face)) "Face used by Ido for matching virtual buffer names." - :version "24.1" - :group 'ido) + :version "24.1") (defface ido-indicator '((((min-colors 88) (class color)) :foreground "yellow1" :background "red1" :width condensed) (((class color)) :foreground "yellow" :background "red" :width condensed) (t :inverse-video t)) - "Face used by Ido for highlighting its indicators." - :group 'ido) + "Face used by Ido for highlighting its indicators.") (defface ido-incomplete-regexp '((t :inherit font-lock-warning-face)) - "Ido face for indicating incomplete regexps." - :group 'ido) + "Ido face for indicating incomplete regexps.") (defcustom ido-make-file-list-hook nil "List of functions to run when the list of matching files is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching files." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-make-dir-list-hook nil "List of functions to run when the list of matching directories is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching directories." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-make-buffer-list-hook nil "List of functions to run when the list of matching buffers is created. Each function on the list may modify the dynamically bound variable `ido-temp-list' which contains the current list of matching buffer names." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-rewrite-file-prompt-functions nil "List of functions to run when the find-file prompt is created. @@ -908,8 +848,7 @@ variables: The following variables are available, but should not be changed: `ido-current-directory' - the unabbreviated directory name item - equals `file' or `dir' depending on the current mode." - :type 'hook - :group 'ido) + :type 'hook) (defvar ido-rewrite-file-prompt-rules nil "Alist of rewriting rules for directory names in Ido prompts. @@ -924,14 +863,12 @@ also modify the dynamic variables described for the variable (defcustom ido-completion-buffer "*Ido Completions*" "Name of completion buffer used by Ido. Set to nil to disable completion buffers popping up." - :type 'string - :group 'ido) + :type 'string) (defcustom ido-completion-buffer-all-completions nil "Non-nil means to show all completions in completion buffer. Otherwise, only the current list of matches is shown." - :type 'boolean - :group 'ido) + :type 'boolean) (defcustom ido-all-frames 'visible "Argument to pass to `walk-windows' when Ido is finding buffers. @@ -939,8 +876,7 @@ See documentation of `walk-windows' for useful values." :type '(choice (const :tag "Selected frame only" nil) (const :tag "All existing frames" t) (const :tag "All visible frames" visible) - (const :tag "All frames on this terminal" 0)) - :group 'ido) + (const :tag "All frames on this terminal" 0))) (defcustom ido-minibuffer-setup-hook nil "Ido-specific customization of minibuffer setup. @@ -954,8 +890,7 @@ with other packages. For instance: will constrain Emacs to a maximum minibuffer height of 3 lines when Ido is running. Copied from `icomplete-minibuffer-setup-hook'." - :type 'hook - :group 'ido) + :type 'hook) (defcustom ido-save-directory-list-file (locate-user-emacs-file "ido.last" ".ido.last") @@ -964,28 +899,24 @@ Variables stored are: `ido-last-directory-list', `ido-work-directory-list', `ido-work-file-list', and `ido-dir-file-cache'. Must be set before enabling Ido mode." :version "24.4" ; added locate-user-emacs-file - :type 'string - :group 'ido) + :type 'string) (defcustom ido-read-file-name-as-directory-commands '() "List of commands which use `read-file-name' to read a directory name. When `ido-everywhere' is non-nil, the commands in this list will read the directory using `ido-read-directory-name'." - :type '(repeat symbol) - :group 'ido) + :type '(repeat symbol)) (defcustom ido-read-file-name-non-ido '() "List of commands which shall not read file names the Ido way. When `ido-everywhere' is non-nil, the commands in this list will read the file name using normal `read-file-name' style." - :type '(repeat symbol) - :group 'ido) + :type '(repeat symbol)) (defcustom ido-before-fallback-functions '() "List of functions to call before calling a fallback command. The fallback command is passed as an argument to the functions." - :type 'hook - :group 'ido) + :type 'hook) ;;;; Keymaps @@ -1071,10 +1002,10 @@ The fallback command is passed as an argument to the functions." ;;;; Persistent variables -(defvar ido-file-history nil +(defvar ido-file-history nil "History of files selected using `ido-find-file'.") -(defvar ido-buffer-history nil +(defvar ido-buffer-history nil "History of buffers selected using `ido-switch-buffer'.") (defvar ido-last-directory-list nil @@ -1583,13 +1514,12 @@ Removes badly formatted data and ignored directories." (ido-save-history)) (defun ido-common-initialization () - (add-hook 'minibuffer-setup-hook 'ido-minibuffer-setup) - (add-hook 'choose-completion-string-functions 'ido-choose-completion-string)) + (add-hook 'minibuffer-setup-hook #'ido-minibuffer-setup) + (add-hook 'choose-completion-string-functions #'ido-choose-completion-string)) (define-minor-mode ido-everywhere "Toggle use of Ido for all buffer/file reading." :global t - :group 'ido (remove-function read-file-name-function #'ido-read-file-name) (remove-function read-buffer-function #'ido-read-buffer) (when ido-everywhere @@ -1619,13 +1549,13 @@ This function also adds a hook to the minibuffer." ((> (prefix-numeric-value arg) 0) 'both) (t nil))) - (ido-everywhere (if ido-everywhere 1 -1)) + (ido-everywhere (if (and ido-mode ido-everywhere) 1 -1)) (when ido-mode (ido-common-initialization) (ido-load-history) - (add-hook 'kill-emacs-hook 'ido-kill-emacs-hook) + (add-hook 'kill-emacs-hook #'ido-kill-emacs-hook) (let ((map (make-sparse-keymap))) (when (memq ido-mode '(file both)) @@ -2445,9 +2375,9 @@ If cursor is not at the end of the user input, move to end of input." nil ido-text 'ido-enter-insert-file)) ((eq ido-exit 'dired) - (funcall (cond ((eq method 'other-window) 'dired-other-window) - ((eq method 'other-frame) 'dired-other-frame) - (t 'dired)) + (funcall (cond ((eq method 'other-window) #'dired-other-window) + ((eq method 'other-frame) #'dired-other-frame) + (t #'dired)) (concat ido-current-directory (or ido-text "")))) ((eq ido-exit 'ffap) @@ -3480,13 +3410,18 @@ instead removed from the current item list." (defun ido-make-buffer-list-1 (&optional frame visible) "Return list of non-ignored buffer names." - (delq nil - (mapcar - (lambda (x) - (let ((name (buffer-name x))) - (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible))) - name))) - (buffer-list frame)))) + (with-temp-buffer + ;; Each call to ido-ignore-item-p LET-binds case-fold-search. + ;; That is slow if there's no buffer-local binding available, + ;; roughly O(number of buffers). This hack avoids it. + (setq-local case-fold-search nil) + (delq nil + (mapcar + (lambda (x) + (let ((name (buffer-name x))) + (if (not (or (ido-ignore-item-p name ido-ignore-buffers) (member name visible))) + name))) + (buffer-list frame))))) (defun ido-make-buffer-list (default) "Return the current list of buffers. @@ -3598,7 +3533,7 @@ it is put to the start of the list." ;; tramp-ftp-file-name-p is available only when tramp ;; has been loaded. (fboundp 'tramp-ftp-file-name-p) - (funcall 'tramp-ftp-file-name-p dir) + (tramp-ftp-file-name-p dir) (string-match ":\\'" dir) (file-name-all-completions "" (concat dir "./")))))) (if (and compl @@ -3698,7 +3633,8 @@ in this list." (not (ido-local-file-exists-p x))) (and (not (ido-final-slash x)) (let (file-name-handler-alist) - (get-file-buffer x)))) x)) + (get-file-buffer x)))) + x)) ido-temp-list))))) (ido-to-end ;; move . files to end (delq nil (mapcar @@ -3731,7 +3667,8 @@ If MERGED is non-nil, each subdir is cons'ed with DIR." (delq nil (mapcar (lambda (name) - (and (ido-final-slash name) (not (ido-ignore-item-p name ido-ignore-directories)) + (and (ido-final-slash name) + (not (ido-ignore-item-p name ido-ignore-directories)) (if merged (cons name dir) name))) (ido-file-name-all-completions dir))))) @@ -3997,6 +3934,14 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (when (bobp) (next-completion 1))))) +(defun ido-completion-auto-help () + "Call `ido-completion-help' if `completion-auto-help' is non-nil." + (interactive) + ;; Note: `completion-auto-help' could also be `lazy', but this value + ;; is irrelevant to ido, which is fundamentally eager, so it is + ;; treated the same as t. + (when completion-auto-help + (ido-completion-help))) (defun ido-completion-help () "Show possible completions in the `ido-completion-buffer'." @@ -4041,7 +3986,7 @@ If `ido-change-word-sub' cannot be found in WORD, return nil." (t (copy-sequence (or ido-matches ido-cur-list)))) #'ido-file-lessp))) - ;;(add-hook 'completion-setup-hook 'completion-setup-function) + ;;(add-hook 'completion-setup-hook #'completion-setup-function) (display-completion-list completion-list)))))) ;;; KILL CURRENT BUFFER @@ -4707,7 +4652,9 @@ For details of keybindings, see `ido-find-file'." (not (input-pending-p))) (ido-trace "\n*start timer*") (setq ido-auto-merge-timer - (run-with-timer ido-auto-merge-delay-time nil 'ido-initiate-auto-merge (current-buffer)))))) + (run-with-timer ido-auto-merge-delay-time nil + #'ido-initiate-auto-merge + (current-buffer)))))) (setq ido-rescan t) @@ -4830,8 +4777,8 @@ Modified from `icomplete-completions'." "Minibuffer setup hook for Ido." ;; Copied from `icomplete-minibuffer-setup-hook'. (when (ido-active) - (add-hook 'pre-command-hook 'ido-tidy nil t) - (add-hook 'post-command-hook 'ido-exhibit nil t) + (add-hook 'pre-command-hook #'ido-tidy nil t) + (add-hook 'post-command-hook #'ido-exhibit nil t) (run-hooks 'ido-minibuffer-setup-hook) (when ido-initial-position (goto-char (+ (minibuffer-prompt-end) ido-initial-position)) diff --git a/lisp/ielm.el b/lisp/ielm.el index 41675c011d8..b3654b91d37 100644 --- a/lisp/ielm.el +++ b/lisp/ielm.el @@ -44,8 +44,7 @@ (defcustom ielm-noisy t "If non-nil, IELM will beep on error." - :type 'boolean - :group 'ielm) + :type 'boolean) (defcustom ielm-prompt-read-only t "If non-nil, the IELM prompt is read only. @@ -74,7 +73,6 @@ buffers, including IELM buffers. If you sometimes use IELM on text-only terminals or with `emacs -nw', you might wish to use another binding for `comint-kill-whole-line'." :type 'boolean - :group 'ielm :version "22.1") (defcustom ielm-prompt "ELISP> " @@ -90,8 +88,7 @@ does not update the prompt of an *ielm* buffer with a running process. For IELM buffers that are not called `*ielm*', you can execute \\[inferior-emacs-lisp-mode] in that IELM buffer to update the value, for new prompts. This works even if the buffer has a running process." - :type 'string - :group 'ielm) + :type 'string) (defvar ielm-prompt-internal "ELISP> " "Stored value of `ielm-prompt' in the current IELM buffer. @@ -103,8 +100,7 @@ customizes `ielm-prompt'.") "Controls whether \\<ielm-map>\\[ielm-return] has intelligent behavior in IELM. If non-nil, \\[ielm-return] evaluates input for complete sexps, or inserts a newline and indents for incomplete sexps. If nil, always inserts newlines." - :type 'boolean - :group 'ielm) + :type 'boolean) (defcustom ielm-dynamic-multiline-inputs t "Force multiline inputs to start from column zero? @@ -112,15 +108,13 @@ If non-nil, after entering the first line of an incomplete sexp, a newline will be inserted after the prompt, moving the input to the next line. This gives more frame width for large indented sexps, and allows functions such as `edebug-defun' to work with such inputs." - :type 'boolean - :group 'ielm) + :type 'boolean) (defvaralias 'inferior-emacs-lisp-mode-hook 'ielm-mode-hook) (defcustom ielm-mode-hook nil "Hooks to be run when IELM (`inferior-emacs-lisp-mode') is started." :options '(eldoc-mode) - :type 'hook - :group 'ielm) + :type 'hook) ;; We define these symbols (that are only used buffer-locally in ielm ;; buffers) this way to avoid having them be defined in the global @@ -366,9 +360,9 @@ nonempty, then flushes the buffer." ;; that same let. To avoid problems, neither of ;; these buffers should be alive during the ;; evaluation of form. - (let* ((*1 *) - (*2 **) - (*3 ***) + (let* ((*1 (bound-and-true-p *)) + (*2 (bound-and-true-p **)) + (*3 (bound-and-true-p ***)) (active-process (ielm-process)) (old-standard-output standard-output) new-standard-output @@ -453,11 +447,12 @@ nonempty, then flushes the buffer." (if error-type (progn (when ielm-noisy (ding)) - (setq output (concat output "*** " error-type " *** ")) - (setq output (concat output result))) + (setq output (concat output + "*** " error-type " *** " + result))) ;; There was no error, so shift the *** values - (setq *** **) - (setq ** *) + (setq *** (bound-and-true-p **)) + (setq ** (bound-and-true-p *)) (setq * result)) (when (or (not for-effect) (not (equal output ""))) (setq output (concat output "\n")))) @@ -541,8 +536,10 @@ Customized bindings may be defined in `ielm-map', which currently contains: (set (make-local-variable 'completion-at-point-functions) '(comint-replace-by-expanded-history ielm-complete-filename elisp-completion-at-point)) - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) (set (make-local-variable 'ielm-prompt-internal) ielm-prompt) (set (make-local-variable 'comint-prompt-read-only) ielm-prompt-read-only) (setq comint-get-old-input 'ielm-get-old-input) diff --git a/lisp/image-dired.el b/lisp/image-dired.el index 768e941490d..6f297672caf 100644 --- a/lisp/image-dired.el +++ b/lisp/image-dired.el @@ -149,7 +149,6 @@ ;;; Code: (require 'dired) -(require 'format-spec) (require 'image-mode) (require 'widget) @@ -771,8 +770,8 @@ Increase at own risk.") process) (when (not (file-exists-p thumbnail-dir)) (message "Creating thumbnail directory") - (make-directory thumbnail-dir t) - (set-file-modes thumbnail-dir #o700)) + (with-file-modes #o700 + (make-directory thumbnail-dir t))) ;; Thumbnail file creation processes begin here and are marshaled ;; in a queue by `image-dired-create-thumb'. diff --git a/lisp/image.el b/lisp/image.el index 4ea8594a974..4b2faa992fc 100644 --- a/lisp/image.el +++ b/lisp/image.el @@ -784,6 +784,7 @@ number, play until that number of seconds has elapsed." (if (setq timer (image-animate-timer image)) (cancel-timer timer)) (plist-put (cdr image) :animate-buffer (current-buffer)) + (plist-put (cdr image) :animate-tardiness 0) (run-with-timer 0.2 nil #'image-animate-timeout image (or index 0) (car animation) 0 limit (+ (float-time) 0.2))))) @@ -848,9 +849,14 @@ The minimum delay between successive frames is `image-minimum-frame-delay'. If the image has a non-nil :speed property, it acts as a multiplier for the animation speed. A negative value means to animate in reverse." + ;; We keep track of "how late" image frames arrive. We decay the + ;; previous cumulative value by 10% and then add the current delay. + (plist-put (cdr image) :animate-tardiness + (+ (* (plist-get (cdr image) :animate-tardiness) 0.9) + (float-time (time-since target-time)))) (when (and (buffer-live-p (plist-get (cdr image) :animate-buffer)) - ;; Delayed more than two seconds more than expected. - (or (time-less-p (time-since target-time) 2) + ;; Cumulatively delayed two seconds more than expected. + (or (< (plist-get (cdr image) :animate-tardiness) 2) (progn (message "Stopping animation; animation possibly too big") nil))) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index b8542bc3c35..5b5c27dbe17 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -26,6 +26,7 @@ (require 'url) (require 'url-cache) +(require 'dns) (eval-when-compile (require 'subr-x)) @@ -118,9 +119,45 @@ a gravatar for a given email address." :version "27.1" :group 'gravatar) -(defconst gravatar-base-url - "https://www.gravatar.com/avatar" - "Base URL for getting gravatars.") +(defconst gravatar-service-alist + `((gravatar . ,(lambda (_addr) "https://www.gravatar.com/avatar")) + (unicornify . ,(lambda (_addr) "https://unicornify.pictures/avatar/")) + (libravatar . ,#'gravatar--service-libravatar)) + "Alist of supported gravatar services.") + +(defcustom gravatar-service 'gravatar + "Symbol denoting gravatar-like service to use. +Note that certain services might ignore other options, such as +`gravatar-default-image' or certain values as with +`gravatar-rating'. + +Note that `'libravatar' has security implications: It can be used +to track whether you're reading a specific mail." + :type `(choice ,@(mapcar (lambda (s) `(const ,(car s))) + gravatar-service-alist)) + :version "28.1" + :link '(url-link "https://www.libravatar.org/") + :link '(url-link "https://unicornify.pictures/") + :link '(url-link "https://gravatar.com/") + :group 'gravatar) + +(defun gravatar--service-libravatar (addr) + "Find domain that hosts avatars for email address ADDR." + ;; implements https://wiki.libravatar.org/api/ + (save-match-data + (if (not (string-match ".+@\\(.+\\)" addr)) + "https://seccdn.libravatar.org/avatar" + (let ((domain (match-string 1 addr))) + (catch 'found + (dolist (record '(("_avatars-sec" . "https") + ("_avatars" . "http"))) + (let* ((query (concat (car record) "._tcp." domain)) + (result (dns-query query 'SRV))) + (when result + (throw 'found (format "%s://%s/avatar" + (cdr record) + result))))) + "https://seccdn.libravatar.org/avatar"))))) (defun gravatar-hash (mail-address) "Return the Gravatar hash for MAIL-ADDRESS." @@ -142,7 +179,8 @@ a gravatar for a given email address." "Return the URL of a gravatar for MAIL-ADDRESS." ;; https://gravatar.com/site/implement/images/ (format "%s/%s?%s" - gravatar-base-url + (funcall (alist-get gravatar-service gravatar-service-alist) + mail-address) (gravatar-hash mail-address) (gravatar--query-string))) diff --git a/lisp/info-look.el b/lisp/info-look.el index fb3237efbb1..4e379cadef1 100644 --- a/lisp/info-look.el +++ b/lisp/info-look.el @@ -75,7 +75,7 @@ List elements are cons cells of the form If a file name matches REGEXP, then use help mode MODE instead of the buffer's major mode." - :group 'info-lookup :type '(repeat (cons (string :tag "Regexp") + :group 'info-lookup :type '(repeat (cons (regexp :tag "Regexp") (symbol :tag "Mode")))) (defvar info-lookup-history nil diff --git a/lisp/info.el b/lisp/info.el index 033a7a5cbb5..78f88947c79 100644 --- a/lisp/info.el +++ b/lisp/info.el @@ -3790,20 +3790,8 @@ Build a menu of the possible matches." ;; there is no "nxml.el" (it's nxml-mode.el). ;; But package.el makes the same assumption. ;; I think nxml is the only exception - maybe it should be just be renamed. - (let ((str (ignore-errors (lm-commentary (find-library-name nodename))))) - (if (null str) - (insert "Can’t find package description.\n\n") - (insert - (with-temp-buffer - (insert str) - (goto-char (point-min)) - (delete-blank-lines) - (goto-char (point-max)) - (delete-blank-lines) - (goto-char (point-min)) - (while (re-search-forward "^;+ ?" nil t) - (replace-match "" nil nil)) - (buffer-string)))))))) + (insert (or (ignore-errors (lm-commentary (find-library-name nodename))) + (insert "Can’t find package description.\n\n")))))) ;;;###autoload (defun info-finder (&optional keywords) @@ -4101,22 +4089,28 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :help "Go to top node of file"] ["Final Node" Info-final-node :help "Go to final node in this file"] + "---" ("Menu Item" ["You should never see this" report-emacs-bug t]) ("Reference" ["You should never see this" report-emacs-bug t]) ["Search..." Info-search :help "Search for regular expression in this Info file"] ["Search Next" Info-search-next :help "Search for another occurrence of regular expression"] - ["Go to Node..." Info-goto-node + "---" + ("History" + ["Back in history" Info-history-back :active Info-history + :help "Go back in history to the last node you were at"] + ["Forward in history" Info-history-forward :active Info-history-forward + :help "Go forward in history"] + ["Show History" Info-history :active Info-history-list + :help "Go to menu of visited nodes"]) + ("Go to" + ["Go to Node..." Info-goto-node :help "Go to a named node"] - ["Back in history" Info-history-back :active Info-history - :help "Go back in history to the last node you were at"] - ["Forward in history" Info-history-forward :active Info-history-forward - :help "Go forward in history"] - ["History" Info-history :active Info-history-list - :help "Go to menu of visited nodes"] - ["Table of Contents" Info-toc - :help "Go to table of contents"] + ["Table of Contents" Info-toc + :help "Go to table of contents"] + ["Go to Directory" Info-directory + :help "Go to the Info directory node."]) ("Index" ["Lookup a String..." Info-index :help "Look for a string in the index items"] @@ -4130,6 +4124,7 @@ If FORK is non-nil, it is passed to `Info-goto-node'." :help "Copy the name of the current node into the kill ring"] ["Clone Info buffer" clone-buffer :help "Create a twin copy of the current Info buffer."] + "---" ["Exit" quit-window :help "Stop reading Info"])) @@ -4380,6 +4375,7 @@ Moving within a node: already visible, try to go to the previous menu entry, or up if there is none. \\[beginning-of-buffer] Go to beginning of node. +\\[end-of-buffer] Go to end of node. Advanced commands: \\[Info-search] Search through this Info file for specified regexp, @@ -5145,9 +5141,8 @@ first line or header line, and for breadcrumb links.") "Additional menu-items to add to speedbar frame.") ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (Info-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'Info-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (Info-install-speedbar-variables)) ;;; Info hierarchy display method ;;;###autoload diff --git a/lisp/informat.el b/lisp/informat.el index 9873f66f215..7750ab00898 100644 --- a/lisp/informat.el +++ b/lisp/informat.el @@ -337,7 +337,7 @@ Check that every node pointer points to an existing node." (point)))) (Info-extract-menu-node-name)))) (goto-char (point-min)) - (while (re-search-forward "\\*note[ \n]*[^:\t]*:" nil t) + (while (re-search-forward "\\*note\\>[^:\t]*:" nil t) (goto-char (+ (match-beginning 0) 5)) (skip-chars-forward " \n") (Info-validate-node-name diff --git a/lisp/international/mule-cmds.el b/lisp/international/mule-cmds.el index 9644b0effd6..7714a778fcb 100644 --- a/lisp/international/mule-cmds.el +++ b/lisp/international/mule-cmds.el @@ -283,8 +283,42 @@ wrong, use this command again to toggle back to the right mode." (interactive) (view-file (expand-file-name "HELLO" data-directory))) +(defvar mule-cmds--prefixed-command-next-coding-system nil) +(defvar mule-cmds--prefixed-command-last-coding-system nil) + +(defun mule-cmds--prefixed-command-pch () + (if (not mule-cmds--prefixed-command-next-coding-system) + (progn + (remove-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch) + (remove-hook 'prefix-command-echo-keystrokes-functions + #'mule-cmds--prefixed-command-echo) + (remove-hook 'prefix-command-preserve-state-hook + #'mule-cmds--prefixed-command-preserve)) + (setq this-command + (let ((cmd this-command) + (coding-system mule-cmds--prefixed-command-next-coding-system)) + (lambda () + (interactive) + (setq this-command cmd) + (let ((coding-system-for-read coding-system) + (coding-system-for-write coding-system) + (coding-system-require-warning t)) + (call-interactively cmd))))) + (setq mule-cmds--prefixed-command-last-coding-system + mule-cmds--prefixed-command-next-coding-system) + (setq mule-cmds--prefixed-command-next-coding-system nil))) + +(defun mule-cmds--prefixed-command-echo () + (when mule-cmds--prefixed-command-next-coding-system + (format "With coding-system %S" + mule-cmds--prefixed-command-next-coding-system))) + +(defun mule-cmds--prefixed-command-preserve () + (setq mule-cmds--prefixed-command-next-coding-system + mule-cmds--prefixed-command-last-coding-system)) + (defun universal-coding-system-argument (coding-system) - "Execute an I/O command using the specified coding system." + "Execute an I/O command using the specified CODING-SYSTEM." (interactive (let ((default (and buffer-file-coding-system (not (eq (coding-system-type buffer-file-coding-system) @@ -295,41 +329,13 @@ wrong, use this command again to toggle back to the right mode." (format "Coding system for following command (default %s): " default) "Coding system for following command: ") default)))) - ;; FIXME: This "read-key-sequence + call-interactively" loop is trying to - ;; reproduce the normal command loop, but this "can't" be done faithfully so - ;; it necessarily suffers from breakage in corner cases (e.g. it fails to run - ;; pre/post-command-hook, doesn't properly set this-command/last-command, it - ;; doesn't handle keyboard macros, ...). - (let* ((keyseq (read-key-sequence - (format "Command to execute with %s:" coding-system))) - (cmd (key-binding keyseq))) - ;; read-key-sequence ignores quit, so make an explicit check. - (if (equal last-input-event (nth 3 (current-input-mode))) - (keyboard-quit)) - (when (memq cmd '(universal-argument digit-argument)) - (call-interactively cmd) - - ;; Process keys bound in `universal-argument-map'. - (while (progn - (setq keyseq (read-key-sequence nil t) - cmd (key-binding keyseq t)) - (memq cmd '(negative-argument digit-argument - universal-argument-more))) - (setq current-prefix-arg prefix-arg prefix-arg nil) - ;; Have to bind `last-command-event' here so that - ;; `digit-argument', for instance, can compute the - ;; `prefix-arg'. - (setq last-command-event (aref keyseq 0)) - (call-interactively cmd))) - - (let ((coding-system-for-read coding-system) - (coding-system-for-write coding-system) - (coding-system-require-warning t)) - (setq current-prefix-arg prefix-arg prefix-arg nil) - ;; Have to bind `last-command-event' e.g. for `self-insert-command'. - (setq last-command-event (aref keyseq 0)) - (message "") - (call-interactively cmd)))) + (prefix-command-preserve-state) + (setq mule-cmds--prefixed-command-next-coding-system coding-system) + (add-hook 'pre-command-hook #'mule-cmds--prefixed-command-pch) + (add-hook 'prefix-command-echo-keystrokes-functions + #'mule-cmds--prefixed-command-echo) + (add-hook 'prefix-command-preserve-state-hook + #'mule-cmds--prefixed-command-preserve)) (defun set-default-coding-systems (coding-system) "Set default value of various coding systems to CODING-SYSTEM. @@ -700,8 +706,8 @@ DEFAULT is the coding system to use by default in the query." ;; buffer is displayed. (when (and unsafe (not (stringp from))) (pop-to-buffer bufname) - (goto-char (apply 'min (mapcar #'(lambda (x) (car (cadr x))) - unsafe)))) + (goto-char (apply #'min (mapcar (lambda (x) (or (car (cadr x)) (point-max))) + unsafe)))) ;; Then ask users to select one from CODINGS while showing ;; the reason why none of the defaults are not used. (with-output-to-temp-buffer "*Warning*" @@ -1402,13 +1408,13 @@ The commands `describe-input-method' and `list-input-methods' need these duplicated values to show some information about input methods without loading the relevant Quail packages. \n(fn INPUT-METHOD LANG-ENV ACTIVATE-FUNC TITLE DESCRIPTION &rest ARGS)" - (if (symbolp lang-env) - (setq lang-env (symbol-name lang-env)) - (setq lang-env (purecopy lang-env))) - (if (symbolp input-method) - (setq input-method (symbol-name input-method)) - (setq input-method (purecopy input-method))) - (setq args (mapcar 'purecopy args)) + (setq lang-env (if (symbolp lang-env) + (symbol-name lang-env) + (purecopy lang-env))) + (setq input-method (if (symbolp input-method) + (symbol-name input-method) + (purecopy input-method))) + (setq args (mapcar #'purecopy args)) (let ((info (cons lang-env args)) (slot (assoc input-method input-method-alist))) (if slot diff --git a/lisp/international/mule-conf.el b/lisp/international/mule-conf.el index e6e6135243f..edda79ba4ee 100644 --- a/lisp/international/mule-conf.el +++ b/lisp/international/mule-conf.el @@ -1517,6 +1517,10 @@ for decoding and encoding files, process I/O, etc." :charset-list '(unicode) :pre-write-conversion 'utf-7-pre-write-conversion :post-read-conversion 'utf-7-post-read-conversion) +;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p, +;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII +;; compatible, so we override that here (bug#40407). +(coding-system-put 'utf-7 :ascii-compatible-p nil) (define-coding-system 'utf-7-imap "UTF-7 encoding of Unicode, IMAP version (RFC 2060)" @@ -1525,6 +1529,8 @@ for decoding and encoding files, process I/O, etc." :charset-list '(unicode) :pre-write-conversion 'utf-7-imap-pre-write-conversion :post-read-conversion 'utf-7-imap-post-read-conversion) +;; See comment for utf-7 above. +(coding-system-put 'utf-7-imap :ascii-compatible-p nil) ;; Use us-ascii for terminal output if some other coding system is not ;; specified explicitly. diff --git a/lisp/international/mule.el b/lisp/international/mule.el index 86f3d2a34bf..df71205d515 100644 --- a/lisp/international/mule.el +++ b/lisp/international/mule.el @@ -30,12 +30,13 @@ ;;; Code: -;; FIXME? Are these still relevant? Nothing uses them AFAICS. (defconst mule-version "6.0 (HANACHIRUSATO)" "\ Version number and name of this version of MULE (multilingual environment).") +(make-obsolete-variable 'mule-version nil "28.1") (defconst mule-version-date "2003.9.1" "\ Distribution date of this version of MULE (multilingual environment).") +(make-obsolete-variable 'mule-version-date nil "28.1") ;;; CHARSET @@ -768,11 +769,12 @@ decoded by the coding system itself and before any functions in `after-insert-functions' are called. This function is passed one argument: the number of characters in the text to convert, with point at the start of the text. The function should leave point -unchanged, and should return the new character count. Note that -this function should avoid reading from files or receiving text -from subprocesses -- anything that could invoke decoding; if it -must do so, it should bind `coding-system-for-read' to a value -other than the current coding-system, to avoid infinite recursion. +and the match data unchanged, and should return the new character +count. Note that this function should avoid reading from files +or receiving text from subprocesses -- anything that could invoke +decoding; if it must do so, it should bind +`coding-system-for-read' to a value other than the current +coding-system, to avoid infinite recursion. `:pre-write-conversion' @@ -780,13 +782,13 @@ VALUE must be a function to call after all functions in `write-region-annotate-functions' and `buffer-file-format' are called, and before the text is encoded by the coding system itself. This function should convert the whole text in the -current buffer. For backward compatibility, this function is -passed two arguments which can be ignored. Note that this -function should avoid writing to files or sending text to -subprocesses -- anything that could invoke encoding; if it -must do so, it should bind `coding-system-for-write' to a -value other than the current coding-system, to avoid infinite -recursion. +current buffer, and leave the match data unchanged. For backward +compatibility, this function is passed two arguments which can be +ignored. Note that this function should avoid writing to files +or sending text to subprocesses -- anything that could invoke +encoding; if it must do so, it should bind +`coding-system-for-write' to a value other than the current +coding-system, to avoid infinite recursion. `:default-char' diff --git a/lisp/international/rfc1843.el b/lisp/international/rfc1843.el index 7f09eb41d17..c59538f5469 100644 --- a/lisp/international/rfc1843.el +++ b/lisp/international/rfc1843.el @@ -60,7 +60,7 @@ e-mail transmission, news posting, etc." (defcustom rfc1843-newsgroups-regexp "chinese\\|hz" "Regexp of newsgroups in which might be HZ encoded." - :type 'string + :type 'regexp :group 'mime) (defun rfc1843-decode-region (from to) diff --git a/lisp/international/titdic-cnv.el b/lisp/international/titdic-cnv.el index 4f1bcf2f94e..a6dcd02dc68 100644 --- a/lisp/international/titdic-cnv.el +++ b/lisp/international/titdic-cnv.el @@ -1,4 +1,4 @@ -;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding: utf-8-emacs; lexical-binding:t -*- +;;; titdic-cnv.el --- convert cxterm dictionary (TIT format) to Quail package -*- coding:iso-2022-7bit; lexical-binding:t -*- ;; Copyright (C) 1997-1998, 2000-2020 Free Software Foundation, Inc. ;; Copyright (C) 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, @@ -83,9 +83,9 @@ ;; how to select a translation from a list of candidates. (defvar quail-cxterm-package-ext-info - '(("chinese-4corner" "四角") - ("chinese-array30" "30") - ("chinese-ccdospy" "缩拼" + '(("chinese-4corner" "$(0(?-F(B") + ("chinese-array30" "$(0#R#O(B") + ("chinese-ccdospy" "$AKuF4(B" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard Roman transliteration method for Chinese. @@ -94,10 +94,10 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you type a single key for these Pinyin spelling. - Pinyin: zh en eng ang ch an ao ai ong sh ing yu(ü) + Pinyin: zh en eng ang ch an ao ai ong sh ing yu($A(9(B) keyseq: a f g h i j k l s u y v For example: - Chinese: 啊 果 中 文 光 玉 全 + Chinese: $A0!(B $A9{(B $AVP(B $AND(B $A9b(B $ASq(B $AH+(B Pinyin: a guo zhong wen guang yu quan Keyseq: a1 guo4 as1 wf4 guh1 yu..6 qvj6 @@ -106,14 +106,14 @@ For example: For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-ecdict" "英漢" + ("chinese-ecdict" "$(05CKH(B" "In this input method, you enter a Chinese (Big5) character or word by typing the corresponding English word. For example, if you type -\"computer\", \"電腦\" is input. +\"computer\", \"$(0IZH+(B\" is input. \\<quail-translation-docstring>") - ("chinese-etzy" "倚注" + ("chinese-etzy" "$(06/0D(B" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -122,20 +122,20 @@ compose one Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 1, 2, 3, or 4 specifying a tone (SPC:陰平, 1:輕聲, 2:陽平, 3: 上聲, -4:去聲). +SPC, 1, 2, 3, or 4 specifying a tone (SPC:$(0?v(N(B, 1:$(0M=Vy(B, 2:$(0Dm(N(B, 3: $(0&9Vy(B, +4:$(0(+Vy(B). \\<quail-translation-docstring>") - ("chinese-punct-b5" "標B" + ("chinese-punct-b5" "$(0O:(BB" "Input method for Chinese punctuation and symbols of Big5 \(`chinese-big5-1' and `chinese-big5-2').") - ("chinese-punct" "标G" + ("chinese-punct" "$A1j(BG" "Input method for Chinese punctuation and symbols of GB2312 \(`chinese-gb2312').") - ("chinese-py-b5" "拼B" + ("chinese-py-b5" "$(03<(BB" "Pinyin base input method for Chinese Big5 characters \(`chinese-big5-1', `chinese-big5-2'). @@ -153,28 +153,28 @@ method `chinese-qj-b5'. The input method `chinese-py' and `chinese-tonepy' are also Pinyin based, but for the character set GB2312 (`chinese-gb2312').") - ("chinese-qj-b5" "全B") + ("chinese-qj-b5" "$(0)A(BB") - ("chinese-qj" "全G") + ("chinese-qj" "$AH+(BG") - ("chinese-sw" "首尾" + ("chinese-sw" "$AJWN2(B" "Radical base input method for Chinese charset GB2312 (`chinese-gb2312'). In this input method, you enter a Chinese character by typing two -keys. The first key corresponds to the first (首) radical, the second -key corresponds to the last (尾) radical. The correspondence of keys +keys. The first key corresponds to the first ($AJW(B) radical, the second +key corresponds to the last ($AN2(B) radical. The correspondence of keys and radicals is as below: first radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - 心 冖 尸 丶 火 口 扌 氵 讠 艹 亻 木 礻 饣 月 纟 石 王 八 丿 日 辶 犭 竹 一 人 + $APD(B $AZ"(B $AJ,(B $AX<(B $A;p(B $A?Z(B $A^P(B $Ac_(B $AZ%(B $A\3(B $AXi(B $AD>(B $Alj(B $Ab;(B $ATB(B $Afy(B $AJ/(B $AMu(B $A0K(B $AX/(B $AHU(B $AeA(B $Aak(B $AVq(B $AR;(B $AHK(B last radical: a b c d e f g h i j k l m n o p q r s t u v w x y z - 又 山 土 刀 阝 口 衣 疋 大 丁 厶 灬 十 歹 冂 门 今 丨 女 乙 囗 小 厂 虫 弋 卜 + $ASV(B $AI=(B $AMA(B $A56(B $AZb(B $A?Z(B $ARB(B $Aqb(B $A4s(B $A6!(B $A[L(B $Ala(B $AJ.(B $A4u(B $AXg(B $ACE(B $A=q(B $AX-(B $AE.(B $ARR(B $A`m(B $AP!(B $A3'(B $A3f(B $A_.(B $A27(B \\<quail-translation-docstring>") - ("chinese-tonepy" "调拼" + ("chinese-tonepy" "$A5wF4(B" "Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). Pinyin is the standard roman transliteration method for Chinese. @@ -183,18 +183,18 @@ method `chinese-py'. This input method works almost the same way as `chinese-py'. The difference is that you must type 1..5 after each Pinyin spelling to -specify a tone (1:阴平, 2:阳平, 3:上声, 4下声, 5:轻声). +specify a tone (1:$ARuF=(B, 2:$AQtF=(B, 3:$AIOIy(B, 4$AOBIy(B, 5:$AGaIy(B). \\<quail-translation-docstring> -For instance, to input 你, you type \"n i 3 3\", the first \"n i\" is +For instance, to input $ADc(B, you type \"n i 3 3\", the first \"n i\" is a Pinyin, the next \"3\" specifies tone, and the last \"3\" selects the third character from the candidate list. For double-width GB2312 characters corresponding to ASCII, use the input method `chinese-qj'.") - ("chinese-zozy" "零注" + ("chinese-zozy" "$(0I\0D(B" "Zhuyin base input method for Chinese Big5 characters (`chinese-big5-1', `chinese-big5-2'). @@ -203,8 +203,8 @@ compose a Chinese character. In this input method, you enter a Chinese character by first typing keys corresponding to Zhuyin symbols (see the above table) followed by -SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, -7:輕聲). +SPC, 6, 3, 4, or 7 specifying a tone (SPC:$(0?v(N(B, 6:$(0Dm(N(B, 3:$(0&9Vy(B, 4:$(0(+Vy(B, +7:$(0M=Vy(B). \\<quail-translation-docstring>"))) @@ -354,7 +354,7 @@ SPC, 6, 3, 4, or 7 specifying a tone (SPC:陰平, 6:陽平, 3:上聲, 4:去聲, (princ (nth 2 (assoc tit-encode tit-encode-list))) (princ "\" \"") (princ (or title - (if (string-match "[:∷:【]+\\([^:∷:】]+\\)" tit-prompt) + (if (string-match "[:$A!K$(0!(!J(B]+\\([^:$A!K$(0!(!K(B]+\\)" tit-prompt) (substring tit-prompt (match-beginning 1) (match-end 1)) tit-prompt))) (princ "\"\n")) @@ -580,7 +580,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; ) (defvar quail-misc-package-ext-info - '(("chinese-b5-tsangchi" "倉B" + '(("chinese-b5-tsangchi" "$(06A(BB" "cangjie-table.b5" big5 "tsang-b5.el" tsang-b5-converter "\ @@ -590,7 +590,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-b5-quick" "簡B" + ("chinese-b5-quick" "$(0X|(BB" "cangjie-table.b5" big5 "quick-b5.el" quick-b5-converter "\ @@ -600,7 +600,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-tsangchi" "倉C" + ("chinese-cns-tsangchi" "$(GT?(BC" "cangjie-table.cns" iso-2022-cn-ext "tsang-cns.el" tsang-cns-converter "\ @@ -610,7 +610,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-cns-quick" "簡C" + ("chinese-cns-quick" "$(Gv|(BC" "cangjie-table.cns" iso-2022-cn-ext "quick-cns.el" quick-cns-converter "\ @@ -620,7 +620,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # unmodified versions is granted without royalty provided ;; # this notice is preserved.") - ("chinese-py" "拼G" + ("chinese-py" "$AF4(BG" "pinyin.map" cn-gb-2312 "PY.el" py-converter "\ @@ -648,7 +648,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ziranma" "自然" + ("chinese-ziranma" "$AWTH;(B" "ziranma.cin" cn-gb-2312 "ZIRANMA.el" ziranma-converter "\ @@ -676,7 +676,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; You should have received a copy of the GNU General Public License along with ;; CCE. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlau" "刘粤" + ("chinese-ctlau" "$AAuTA(B" "CTLau.html" cn-gb-2312 "CTLau.el" ctlau-gb-converter "\ @@ -701,7 +701,7 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; # You should have received a copy of the GNU General Public License ;; # along with this program. If not, see <https://www.gnu.org/licenses/>.") - ("chinese-ctlaub" "劉粵" + ("chinese-ctlaub" "$(0N,Gn(B" "CTLau-b5.html" big5 "CTLau-b5.el" ctlau-b5-converter "\ @@ -731,38 +731,38 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." ;; dictionary in the buffer DICBUF. The input method name of the ;; Quail package is NAME, and the title string is TITLE. -;; TSANG-P is non-nil, generate 倉頡 input method. Otherwise -;; generate 簡易 (simple version of 倉頡). If BIG5-P is non-nil, the +;; TSANG-P is non-nil, generate $(06AQo(B input method. Otherwise +;; generate $(0X|/y(B (simple version of $(06AQo(B). If BIG5-P is non-nil, the ;; input method is for inputting Big5 characters. Otherwise the input ;; method is for inputting CNS characters. (defun tsang-quick-converter (dicbuf tsang-p big5-p) - (let ((fulltitle (if tsang-p (if big5-p "倉頡" "倉頡") - (if big5-p "簡易" "簡易"))) + (let ((fulltitle (if tsang-p (if big5-p "$(06AQo(B" "$(GT?on(B") + (if big5-p "$(0X|/y(B" "$(Gv|Mx(B"))) dic) (goto-char (point-max)) (if big5-p - (insert (format "\"中文輸入【%s】BIG5 + (insert (format "\"$(0&d'GTT&,!J(B%s$(0!K(BBIG5 - 漢語%s輸入鍵盤 + $(0KHM$(B%s$(0TT&,WoOu(B - [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] + [Q $(0'D(B] [W $(0(q(B] [E $(0'V(B] [R $(0&H(B] [T $(0'>(B] [Y $(0&4(B] [U $(0&U(B] [I $(0'B(B] [O $(0&*(B] [P $(0'A(B] - [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] + [A $(0'K(B] [S $(0&T(B] [D $(0'N(B] [F $(0'W(B] [G $(0&I(B] [H $(0*M(B] [J $(0&3(B] [L $(0&d(B] - [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] + [Z ] [X $(0[E(B] [C $(01[(B] [V $(0&M(B] [B $(0'M(B] [N $(0&_(B] [M $(0&"(B] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle)) - (insert (format "\"中文輸入【%s】CNS + (insert (format "\"$(GDcEFrSD+!J(B%s$(G!K(BCNS - 漢語%s輸入鍵盤 + $(GiGk#(B%s$(GrSD+uomu(B - [Q 手] [W 田] [E 水] [R 口] [T 廿] [Y 卜] [U 山] [I 戈] [O 人] [P 心] + [Q $(GEC(B] [W $(GFp(B] [E $(GEU(B] [R $(GDG(B] [T $(GE=(B] [Y $(GD3(B] [U $(GDT(B] [I $(GEA(B] [O $(GD)(B] [P $(GE@(B] - [A 日] [S 尸] [D 木] [F 火] [G 土] [H 竹] [J 十] [L 中] + [A $(GEJ(B] [S $(GDS(B] [D $(GEM(B] [F $(GEV(B] [G $(GDH(B] [H $(GHL(B] [J $(GD2(B] [L $(GDc(B] - [Z ] [X 難] [C 金] [V 女] [B 月] [N 弓] [M 一] + [Z ] [X $(GyE(B] [C $(GOZ(B] [V $(GDL(B] [B $(GEL(B] [N $(GD^(B] [M $(GD!(B] \\\\<quail-translation-docstring>\"\n" fulltitle fulltitle))) @@ -798,35 +798,35 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (setq dic (sort dic (function (lambda (x y) (string< (car x ) (car y)))))) (dolist (elt dic) (insert (format "(%S\t%S)\n" (car elt) (cdr elt)))) - (let ((punctuation '((";" ";﹔,、﹐﹑" ";﹔,、﹐﹑") - (":" ":︰﹕.。‧﹒·" ":︰﹕.。・﹒·") - ("'" "’‘" "’‘") - ("\"" "”“〝〞〃" "”“〝〞〃") - ("\\" "\﹨╲" "\﹨╲") - ("|" "|︱︳∣" "︱︲|") - ("/" "/∕╱" "/∕╱") - ("?" "?﹖" "?﹖") - ("<" "〈<﹤︿∠" "〈<﹤︿∠") - (">" "〉>﹥﹀" "〉>﹦﹀") - ("[" "〔【﹝︹︻「『﹁﹃" "〔【﹝︹︻「『﹁﹃") - ("]" "〕】﹞︺︼」』﹂﹄" "〕】﹞︺︼」』﹂﹄") - ("{" "{﹛︷ " "{﹛︷ ") - ("}" "}﹜︸" "}﹜︸") - ("`" "‵′" "′‵") - ("~" "~﹋﹌︴﹏" "∼﹋﹌") - ("!" "!﹗" "!﹗") - ("@" "@﹫" "@﹫") - ("#" "#﹟" "#﹟") - ("$" "$﹩" "$﹩") - ("%" "%﹪" "%﹪") - ("&" "&﹠" "&﹠") - ("*" "*﹡※☆★" "*﹡※☆★") - ("(" "(﹙︵" "(﹙︵") - (")" ")﹚︶" ")﹚︶") - ("-" "–—¯ ̄-﹣" "—–‾-﹣") - ("_" "_ˍ" "_") - ("=" "=﹦" "=﹥") - ("+" "+﹢" "+﹢")))) + (let ((punctuation '((";" "$(0!'!2!"!#!.!/(B" "$(G!'!2!"!#!.!/(B") + (":" "$(0!(!+!3!%!$!&!0!1(B" "$(G!(!+!3!%!$!&!0!1(B") + ("'" "$(0!e!d(B" "$(G!e!d(B") + ("\"" "$(0!g!f!h!i!q(B" "$(G!g!f!h!i!q(B") + ("\\" "$(0"`"b#M(B" "$(G"`"b#M(B") + ("|" "$(0!6!8!:"^(B" "$(G!6!8!:"^(B") + ("/" "$(0"_"a#L(B" "$(G"_"a#L(B") + ("?" "$(0!)!4(B" "$(G!)!4(B") + ("<" "$(0!R"6"A!T"H(B" "$(G!R"6"A!T"H(B") + (">" "$(0!S"7"B!U(B" "$(G!S"7"B!U(B") + ("[" "$(0!F!J!b!H!L!V!Z!X!\(B" "$(G!F!J!b!H!L!V!Z!X!\(B") + ("]" "$(0!G!K!c!I!M!W + ("{" "$(0!B!`!D(B " "$(G!B!`!D(B ") + ("}" "$(0!C!a!E(B" "$(G!C!a!E(B") + ("`" "$(0!j!k(B" "$(G!j!k(B") + ("~" "$(0"D"+",!<!=(B" "$(G"D"+",!<!=(B") + ("!" "$(0!*!5(B" "$(G!*!5(B") + ("@" "$(0"i"n(B" "$(G"i"n(B") + ("#" "$(0!l"-(B" "$(G!l"-(B") + ("$" "$(0"c"l(B" "$(G"c"l(B") + ("%" "$(0"h"m(B" "$(G"h"m(B") + ("&" "$(0!m".(B" "$(G!m".(B") + ("*" "$(0!n"/!o!w!x(B" "$(G!n"/!o!w!x(B") + ("(" "$(0!>!^!@(B" "$(G!>!^!@(B") + (")" "$(0!?!_!A(B" "$(G!?!_!A(B") + ("-" "$(0!7!9"#"$"1"@(B" "$(G!7!9"#"$"1"@(B") + ("_" "$(0"%"&(B" "$(G"%"&(B") + ("=" "$(0"8"C(B" "$(G"8"C(B") + ("+" "$(0"0"?(B" "$(G"0"?(B")))) (dolist (elt punctuation) (insert (format "(%S %S)\n" (concat "z" (car elt)) (if big5-p (nth 1 elt) (nth 2 elt)))))) @@ -850,11 +850,11 @@ To get complete usage, invoke \"emacs -batch -f batch-titdic-convert -h\"." (defun py-converter (dicbuf) (goto-char (point-max)) - (insert (format "%S\n" "汉字输入∷拼音∷ + (insert (format "%S\n" "$A::WVJdHk!KF4Rt!K(B - 拼音方案 + $AF4Rt7=08(B - 小写英文字母代表「拼音」符号, \"u(yu) 则用 u: 表示∶ + $AP!P4S"NDWVD84z1m!8F4Rt!97{:E#,(B \"u(yu) $ATrSC(B u: $A1mJ>!C(B Pinyin base input method for Chinese charset GB2312 (`chinese-gb2312'). @@ -868,14 +868,14 @@ character. The sequence is made by the combination of the initials iang ing iong u ua uo uai ui uan un uan ueng yu yue yuan yun (Note: In the correct Pinyin writing, the sequence \"yu\" in the last - four finals should be written by the character u-umlaut `ü'.) + four finals should be written by the character u-umlaut `$A(9(B'.) With this input method, you enter a Chinese character by first entering its pinyin spelling. \\<quail-translation-docstring> -For instance, to input 你, you type \"n i C-n 3\". The first \"n i\" +For instance, to input $ADc(B, you type \"n i C-n 3\". The first \"n i\" is a Pinyin, \"C-n\" selects the next group of candidates (each group contains at most 10 characters), \"3\" select the third character in that group. @@ -958,22 +958,22 @@ method `chinese-tonepy' with which you must specify tones by digits table))) (setq dic (sort dic (function (lambda (x y) (string< (car x) (car y)))))) (goto-char (point-max)) - (insert (format "%S\n" "汉字输入∷【自然】∷ - - 键盘对照表: - ┏━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┳━━┓ - ┃Q ┃W ┃E ┃R ┃T ┃Y ┃Ush┃Ich┃O ┃P ┃ - ┃ iu┃ ua┃ e┃ uan┃ ue┃ uai┃ u┃ i┃ o┃ un┃ - ┃ ┃ ia┃ ┃ van┃ ve┃ ing┃ ┃ ┃ uo┃ vn┃ - ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┛ - ┃A ┃S ┃D ┃F ┃G ┃H ┃J ┃K ┃L ┃ - ┃ a┃iong┃uang┃ en┃ eng┃ ang┃ an┃ ao┃ ai┃ - ┃ ┃ ong┃iang┃ ┃ ng┃ ┃ ┃ ┃ ┃ - ┗┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━┻┳━━┓ - ┃Z ┃X ┃C ┃Vzh┃B ┃N ┃M ┃, ┃. ┃ / ┃ - ┃ ei┃ ie┃ iao┃ ui┃ ou┃ in┃ ian┃前页┃后页┃符号┃ - ┃ ┃ ┃ ┃ v┃ ┃ ┃ ┃ ┃ ┃ ┃ - ┗━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┻━━┛ + (insert (format "%S\n" "$A::WVJdHk!K!>WTH;!?!K(B + + $A<|EL6TUU1m(B: + $A)3)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)W)%)%)7(B + $A)'#Q(B $A)'#W(B $A)'#E(B $A)'#R(B $A)'#T(B $A)'#Y(B $A)'#U(Bsh$A)'#I(Bch$A)'#O(B $A)'#P(B $A)'(B + $A)'(B iu$A)'(B ua$A)'(B e$A)'(B uan$A)'(B ue$A)'(B uai$A)'(B u$A)'(B i$A)'(B o$A)'(B un$A)'(B + $A)'(B $A)'(B ia$A)'(B $A)'(B van$A)'(B ve$A)'(B ing$A)'(B $A)'(B $A)'(B uo$A)'(B vn$A)'(B + $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)?(B + $A)'#A(B $A)'#S(B $A)'#D(B $A)'#F(B $A)'#G(B $A)'#H(B $A)'#J(B $A)'#K(B $A)'#L(B $A)'(B + $A)'(B a$A)'(Biong$A)'(Buang$A)'(B en$A)'(B eng$A)'(B ang$A)'(B an$A)'(B ao$A)'(B ai$A)'(B + $A)'(B $A)'(B ong$A)'(Biang$A)'(B $A)'(B ng$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B + $A);)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)_)W)%)%)7(B + $A)'#Z(B $A)'#X(B $A)'#C(B $A)'#V(Bzh$A)'#B(B $A)'#N(B $A)'#M(B $A)'#,(B $A)'#.(B $A)'(B $A#/(B $A)'(B + $A)'(B ei$A)'(B ie$A)'(B iao$A)'(B ui$A)'(B ou$A)'(B in$A)'(B ian$A)'G0R3)':sR3)'7{:E)'(B + $A)'(B $A)'(B $A)'(B $A)'(B v$A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B $A)'(B + $A);)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)_)%)%)?(B Pinyin base input method for Chinese GB2312 characters (`chinese-gb2312'). @@ -985,34 +985,34 @@ method `chinese-py'. Unlike the standard spelling of Pinyin, in this input method all initials and finals are assigned to single keys (see the above table). For instance, the initial \"ch\" is assigned to the key `i', the final -\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and 轻声 are +\"iu\" is assigned to the key `q', and tones 1, 2, 3, 4, and $AGaIy(B are assigned to the keys `q', `w', `e', `r', `t' respectively. \\<quail-translation-docstring> To input one-letter words, you type 4 keys, the first two for the Pinyin of the letter, next one for tone, and the last one is always a -quote ('). For instance, \"vsq'\" input 中. Exceptions are these +quote ('). For instance, \"vsq'\" input $AVP(B. Exceptions are these letters. You can input them just by typing a single key. - Character: 按 不 次 的 二 发 个 和 出 及 可 了 没 + Character: $A04(B $A2;(B $A4N(B $A5D(B $A6~(B $A7"(B $A8v(B $A:M(B $A3v(B $A<0(B $A?I(B $AAK(B $AC;(B Key: a b c d e f g h i j k l m - Character: 你 欧 片 七 人 三 他 是 着 我 小 一 在 + Character: $ADc(B $AE7(B $AF,(B $AF_(B $AHK(B $AH}(B $AK{(B $AJG(B $AWE(B $ANR(B $AP!(B $AR;(B $ATZ(B Key: n o p q r s t u v w x y z To input two-letter words, you have two ways. One way is to type 4 keys, two for the first Pinyin, two for the second Pinyin. For -instance, \"vsgo\" inputs 中国. Another way is to type 3 keys: 2 +instance, \"vsgo\" inputs $AVP9z(B. Another way is to type 3 keys: 2 initials of two letters, and quote ('). For instance, \"vg'\" also -inputs 中国. +inputs $AVP9z(B. To input three-letter words, you type 4 keys: initials of three -letters, and the last is quote ('). For instance, \"bjy'2\" inputs 北 -京鸭 (the last `2' is to select one of the candidates). +letters, and the last is quote ('). For instance, \"bjy'2\" inputs $A11(B +$A>)Q<(B (the last `2' is to select one of the candidates). To input words of more than three letters, you type 4 keys, initials of the first three letters and the last letter. For instance, -\"bjdt\" inputs 北京电视台. +\"bjdt\" inputs $A11>)5gJSL((B. To input symbols and punctuation, type `/' followed by one of `a' to `z', then select one of the candidates.")) @@ -1059,7 +1059,7 @@ To input symbols and punctuation, type `/' followed by one of `a' to ;; which the file is converted have no Big5 equivalent. Go ;; through and delete them. (goto-char pos) - (while (search-forward "□" nil t) + (while (search-forward "$(0!{(B" nil t) (delete-char -1)) ;; Uppercase keys in dictionary need to be downcased. Backslashes ;; at the beginning of keys need to be turned into double @@ -1083,31 +1083,31 @@ To input symbols and punctuation, type `/' followed by one of `a' to (defun ctlau-gb-converter (dicbuf) (ctlau-converter dicbuf -"汉字输入∷刘锡祥式粤音∷ +"$A::WVJdHk!KAuN}OiJ=TARt!K(B - 刘锡祥式粤语注音方案 + $AAuN}OiJ=TASoW"Rt7=08(B Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee (李枫峰). + This file was prepared by Fung Fung Lee ($A@n7c7e(B). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent GB characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical (部首).")) + the Cantonese romanization of the respective radical ($A2?JW(B).")) (defun ctlau-b5-converter (dicbuf) (ctlau-converter dicbuf -"漢字輸入:劉錫祥式粵音: +"$(0KH)tTT&,!(N,Tg>A*#Gn5x!((B - 劉錫祥式粵語注音方案 + $(0N,Tg>A*#GnM$0D5x'J7{(B Sidney Lau's Cantonese transcription scheme as described in his book \"Elementary Cantonese\", The Government Printer, Hong Kong, 1972. - This file was prepared by Fung Fung Lee (李楓峰). + This file was prepared by Fung Fung Lee ($(0,XFS76(B). Originally converted from CTCPS3.tit Last modified: June 2, 1993. Some infrequent characters are accessed by typing \\, followed by - the Cantonese romanization of the respective radical (部首).")) + the Cantonese romanization of the respective radical ($(0?f5}(B).")) (declare-function dos-8+3-filename "dos-fns.el" (filename)) diff --git a/lisp/international/ucs-normalize.el b/lisp/international/ucs-normalize.el index 201ff6b9b17..b703d3dd2f2 100644 --- a/lisp/international/ucs-normalize.el +++ b/lisp/international/ucs-normalize.el @@ -612,14 +612,16 @@ COMPOSITION-PREDICATE will be used to compose region." (defun ucs-normalize-hfs-nfd-post-read-conversion (len) (save-excursion (save-restriction - (narrow-to-region (point) (+ (point) len)) - (ucs-normalize-HFS-NFC-region (point-min) (point-max)) - (- (point-max) (point-min))))) + (save-match-data + (narrow-to-region (point) (+ (point) len)) + (ucs-normalize-HFS-NFC-region (point-min) (point-max)) + (- (point-max) (point-min)))))) ;; Pre-write conversion for `utf-8-hfs'. ;; _from and _to are legacy arguments (see `define-coding-system'). (defun ucs-normalize-hfs-nfd-pre-write-conversion (_from _to) - (ucs-normalize-HFS-NFD-region (point-min) (point-max))) + (save-match-data + (ucs-normalize-HFS-NFD-region (point-min) (point-max)))) ;;; coding-system definition (define-coding-system 'utf-8-hfs diff --git a/lisp/isearch.el b/lisp/isearch.el index 57b13a38d67..81e83d79509 100644 --- a/lisp/isearch.el +++ b/lisp/isearch.el @@ -2011,15 +2011,16 @@ Turning on character-folding turns off regexp mode.") (defvar isearch-message-properties minibuffer-prompt-properties "Text properties that are added to the isearch prompt.") -(defun isearch--momentary-message (string) - "Print STRING at the end of the isearch prompt for 1 second." +(defun isearch--momentary-message (string &optional seconds) + "Print STRING at the end of the isearch prompt for 1 second. +The optional argument SECONDS overrides the number of seconds." (let ((message-log-max nil)) (message "%s%s%s" (isearch-message-prefix nil isearch-nonincremental) isearch-message (apply #'propertize (format " [%s]" string) isearch-message-properties))) - (sit-for 1)) + (sit-for (or seconds 1))) (isearch-define-mode-toggle lax-whitespace " " nil "In ordinary search, toggles the value of the variable @@ -2381,22 +2382,17 @@ respectively)." (funcall isearch-regexp-function isearch-string)) (isearch-regexp-function (word-search-regexp isearch-string)) (isearch-regexp isearch-string) - ((if (and (eq isearch-case-fold-search t) - search-upper-case) - (isearch-no-upper-case-p - isearch-string isearch-regexp) - isearch-case-fold-search) - ;; Turn isearch-string into a case-insensitive - ;; regexp. - (mapconcat - (lambda (c) - (let ((s (string c))) - (if (string-match "[[:alpha:]]" s) - (format "[%s%s]" (upcase s) (downcase s)) - (regexp-quote s)))) - isearch-string "")) (t (regexp-quote isearch-string))))) - (funcall hi-lock-func regexp (hi-lock-read-face-name))) + (let ((case-fold-search isearch-case-fold-search) + ;; Set `search-upper-case' to nil to not call + ;; `isearch-no-upper-case-p' in `hi-lock'. + (search-upper-case nil) + (search-spaces-regexp + (if (if isearch-regexp + isearch-regexp-lax-whitespace + isearch-lax-whitespace) + search-whitespace-regexp))) + (funcall hi-lock-func regexp (hi-lock-read-face-name) isearch-string))) (and isearch-recursive-edit (exit-recursive-edit))) (defun isearch-highlight-regexp () @@ -2404,14 +2400,18 @@ respectively)." The arguments passed to `highlight-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) - (isearch--highlight-regexp-or-lines 'highlight-regexp)) + (isearch--highlight-regexp-or-lines + #'(lambda (regexp face lighter) + (highlight-regexp regexp face nil lighter)))) (defun isearch-highlight-lines-matching-regexp () "Exit Isearch mode and call `highlight-lines-matching-regexp'. The arguments passed to `highlight-lines-matching-regexp' are the regexp from the last search and the face from `hi-lock-read-face-name'." (interactive) - (isearch--highlight-regexp-or-lines 'highlight-lines-matching-regexp)) + (isearch--highlight-regexp-or-lines + #'(lambda (regexp face _lighter) + (highlight-lines-matching-regexp regexp face)))) (defun isearch-delete-char () @@ -3443,7 +3443,10 @@ Optional third argument, if t, means if fail just return nil (no error). (string-match "\\`Regular expression too big" isearch-error)) (cond (isearch-regexp-function - (setq isearch-error "Too many words")) + (setq isearch-error nil) + (setq isearch-regexp-function nil) + (isearch-search-and-update) + (isearch--momentary-message "Too many words; switched to literal mode" 2)) ((and isearch-lax-whitespace search-whitespace-regexp) (setq isearch-error "Too many spaces for whitespace matching")))))) @@ -3866,9 +3869,10 @@ Attempt to do the search exactly the way the pending Isearch would." (isearch-regexp-lax-whitespace isearch-lazy-highlight-regexp-lax-whitespace) (isearch-forward isearch-lazy-highlight-forward) - ;; Match invisible text only when counting matches - ;; and user can visit invisible matches - (search-invisible (and isearch-lazy-count search-invisible t)) + ;; Don't match invisible text unless it can be opened + ;; or when counting matches and user can visit hidden matches + (search-invisible (or (eq search-invisible 'open) + (and isearch-lazy-count search-invisible))) (retry t) (success nil)) ;; Use a loop like in `isearch-search'. diff --git a/lisp/jit-lock.el b/lisp/jit-lock.el index 95cc02197c1..8b3384ae827 100644 --- a/lisp/jit-lock.el +++ b/lisp/jit-lock.el @@ -48,8 +48,7 @@ Preserves the `buffer-modified-p' state of the current buffer." "Jit-lock fontifies chunks of at most this many characters at a time. This variable controls both display-time and stealth fontification." - :type 'integer - :group 'jit-lock) + :type 'integer) (defcustom jit-lock-stealth-time nil @@ -59,8 +58,7 @@ If nil, stealth fontification is never performed. The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) - (number :tag "seconds" :value 16)) - :group 'jit-lock) + (number :tag "seconds" :value 16))) (defcustom jit-lock-stealth-nice 0.5 @@ -72,8 +70,7 @@ To reduce machine load during stealth fontification, at the cost of stealth taking longer to fontify, you could increase the value of this variable. See also `jit-lock-stealth-load'." :type '(choice (const :tag "never" nil) - (number :tag "seconds")) - :group 'jit-lock) + (number :tag "seconds"))) (defcustom jit-lock-stealth-load @@ -89,14 +86,12 @@ See also `jit-lock-stealth-nice'." :type (if (condition-case nil (load-average) (error)) '(choice (const :tag "never" nil) (integer :tag "load")) - '(const :format "%t: unsupported\n" nil)) - :group 'jit-lock) + '(const :format "%t: unsupported\n" nil))) (defcustom jit-lock-stealth-verbose nil "If non-nil, means stealth fontification should show status messages." - :type 'boolean - :group 'jit-lock) + :type 'boolean) (defvaralias 'jit-lock-defer-contextually 'jit-lock-contextually) @@ -121,13 +116,11 @@ and sets the buffer-local value of `jit-lock-contextually' to t). The value of this variable is used when JIT Lock mode is turned on." :type '(choice (const :tag "never" nil) (const :tag "always" t) - (other :tag "syntax-driven" syntax-driven)) - :group 'jit-lock) + (other :tag "syntax-driven" syntax-driven))) (defcustom jit-lock-context-time 0.5 "Idle time after which text is contextually refontified, if applicable." - :type '(number :tag "seconds") - :group 'jit-lock) + :type '(number :tag "seconds")) (defcustom jit-lock-antiblink-grace 2 "Delay after which to refontify unterminated strings and comments. @@ -140,14 +133,12 @@ and comments, the delay helps avoid unpleasant \"blinking\", between string/comment and non-string/non-comment fontification." :type '(choice (const :tag "never" nil) (number :tag "seconds")) - :group 'jit-lock :version "27.1") (defcustom jit-lock-defer-time nil ;; 0.25 "Idle time after which deferred fontification should take place. If nil, fontification is not deferred. If 0, then fontification is only deferred while there is input pending." - :group 'jit-lock :type '(choice (const :tag "never" nil) (number :tag "seconds"))) @@ -156,9 +147,10 @@ If 0, then fontification is only deferred while there is input pending." (defvar-local jit-lock-mode nil "Non-nil means Just-in-time Lock mode is active.") -(defvar-local jit-lock-functions nil - "Functions to do the actual fontification. -They are called with two arguments: the START and END of the region to fontify.") +(defvar jit-lock-functions nil + "Special hook run to do the actual fontification. +The functions are called with two arguments: +the START and END of the region to fontify.") (defvar-local jit-lock-context-unfontify-pos nil "Consider text after this position as contextually unfontified. @@ -268,7 +260,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." ;; Setup our hooks. (add-hook 'after-change-functions 'jit-lock-after-change nil t) - (add-hook 'fontification-functions 'jit-lock-function)) + (add-hook 'fontification-functions 'jit-lock-function nil t)) ;; Turn Just-in-time Lock mode off. (t @@ -300,7 +292,7 @@ If you need to debug code run from jit-lock, see `jit-lock-debug-mode'." When this minor mode is enabled, jit-lock runs as little code as possible during redisplay and moves the rest to a timer, where things like `debug-on-error' and Edebug can be used." - :global t :group 'jit-lock + :global t (when jit-lock-defer-timer (cancel-timer jit-lock-defer-timer) (setq jit-lock-defer-timer nil)) @@ -350,7 +342,8 @@ If non-nil, CONTEXTUAL means that a contextual fontification would be useful." "Unregister FUN as a fontification function. Only applies to the current buffer." (remove-hook 'jit-lock-functions fun t) - (unless jit-lock-functions (jit-lock-mode nil))) + (when (member jit-lock-functions '(nil '(t))) + (jit-lock-mode nil))) (defun jit-lock-refontify (&optional beg end) "Force refontification of the region BEG..END (default whole buffer)." @@ -444,8 +437,8 @@ Defaults to the whole buffer. END can be out of bounds." (quit (put-text-property start next 'fontified nil) (signal (car err) (cdr err)))))) - ;; In case we fontified more than requested, take advantage of the - ;; good news. + ;; In case we fontified more than requested, take + ;; advantage of the good news. (when (or (< tight-beg start) (> tight-end next)) (put-text-property tight-beg tight-end 'fontified t)) diff --git a/lisp/json.el b/lisp/json.el index ac323dac295..9002e868537 100644 --- a/lisp/json.el +++ b/lisp/json.el @@ -3,7 +3,7 @@ ;; Copyright (C) 2006-2020 Free Software Foundation, Inc. ;; Author: Theresa O'Connor <ted@oconnor.cx> -;; Version: 1.4 +;; Version: 1.5 ;; Keywords: convenience ;; This file is part of GNU Emacs. @@ -29,11 +29,11 @@ ;; Learn all about JSON here: <URL:http://json.org/>. ;; The user-serviceable entry points for the parser are the functions -;; `json-read' and `json-read-from-string'. The encoder has a single +;; `json-read' and `json-read-from-string'. The encoder has a single ;; entry point, `json-encode'. ;; Since there are several natural representations of key-value pair -;; mappings in elisp (alist, plist, hash-table), `json-read' allows you +;; mappings in Elisp (alist, plist, hash-table), `json-read' allows you ;; to specify which you'd prefer (see `json-object-type' and ;; `json-array-type'). @@ -55,6 +55,7 @@ ;;; Code: (require 'map) +(require 'seq) (require 'subr-x) ;; Parameters @@ -113,8 +114,10 @@ Used only when `json-encoding-pretty-print' is non-nil.") "If non-nil, then the output of `json-encode' will be pretty-printed.") (defvar json-encoding-lisp-style-closings nil - "If non-nil, ] and } closings will be formatted lisp-style, -without indentation.") + "If non-nil, delimiters ] and } will be formatted Lisp-style. +This means they will be placed on the same line as the last +element of the respective array or object, without indentation. +Used only when `json-encoding-pretty-print' is non-nil.") (defvar json-encoding-object-sort-predicate nil "Sorting predicate for JSON object keys during encoding. @@ -124,88 +127,81 @@ instance, setting this to `string<' will have JSON object keys ordered alphabetically.") (defvar json-pre-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right before reading a JSON array or object, -respectively. The function is called with one argument, which is -the current JSON key.") + "If non-nil, a function to call before reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with one argument, which is the current JSON key.") (defvar json-post-element-read-function nil - "Function called (if non-nil) by `json-read-array' and -`json-read-object' right after reading a JSON array or object, -respectively.") + "If non-nil, a function to call after reading a JSON array or object. +It is called by `json-read-array' and `json-read-object', +respectively, with no arguments.") ;;; Utilities -(defun json-join (strings separator) - "Join STRINGS with SEPARATOR." - (mapconcat 'identity strings separator)) +(define-obsolete-function-alias 'json-join #'string-join "28.1") (defun json-alist-p (list) - "Non-null if and only if LIST is an alist with simple keys." - (while (consp list) - (setq list (if (and (consp (car list)) - (atom (caar list))) - (cdr list) - 'not-alist))) + "Non-nil if and only if LIST is an alist with simple keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (consp (car-safe list)) + (atom (caar list)) + (setq list (cdr list)))) (null list)) (defun json-plist-p (list) - "Non-null if and only if LIST is a plist with keyword keys." - (while (consp list) - (setq list (if (and (keywordp (car list)) - (consp (cdr list))) - (cddr list) - 'not-plist))) + "Non-nil if and only if LIST is a plist with keyword keys." + (declare (pure t) (side-effect-free error-free)) + (while (and (keywordp (car-safe list)) + (consp (cdr list)) + (setq list (cddr list)))) (null list)) -(defun json--plist-reverse (plist) - "Return a copy of PLIST in reverse order. -Unlike `reverse', this keeps the property-value pairs intact." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push val res) - (push prop res))) - res)) - -(defun json--plist-to-alist (plist) - "Return an alist of the property-value pairs in PLIST." - (let (res) - (while plist - (let ((prop (pop plist)) - (val (pop plist))) - (push (cons prop val) res))) - (nreverse res))) - -(defmacro json--with-indentation (body) +(defun json--plist-nreverse (plist) + "Return PLIST in reverse order. +Unlike `nreverse', this keeps the ordering of each property +relative to its value intact. Like `nreverse', this function may +destructively modify PLIST to produce the result." + (let (prev (next (cddr plist))) + (while next + (setcdr (cdr plist) prev) + (setq prev plist plist next next (cddr next)) + (setcdr (cdr plist) prev))) + plist) + +(defmacro json--with-indentation (&rest body) + "Evaluate BODY with the correct indentation for JSON encoding. +This macro binds `json--encoding-current-indentation' according +to `json-encoding-pretty-print' around BODY." + (declare (debug t) (indent 0)) `(let ((json--encoding-current-indentation (if json-encoding-pretty-print (concat json--encoding-current-indentation json-encoding-default-indentation) ""))) - ,body)) + ,@body)) ;; Reader utilities (define-inline json-advance (&optional n) - "Advance N characters forward." + "Advance N characters forward, or 1 character if N is nil. +On reaching the end of the accessible region of the buffer, stop +and signal an error." (inline-quote (forward-char ,n))) (define-inline json-peek () - "Return the character at point." + "Return the character at point. +At the end of the accessible region of the buffer, return 0." (inline-quote (following-char))) (define-inline json-pop () - "Advance past the character at point, returning it." + "Advance past the character at point, returning it. +Signal `json-end-of-file' if called at the end of the buffer." (inline-quote - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-advance) - char)))) + (prog1 (or (char-after) + (signal 'json-end-of-file ())) + (json-advance)))) (define-inline json-skip-whitespace () "Skip past the whitespace at point." @@ -213,7 +209,7 @@ Unlike `reverse', this keeps the property-value pairs intact." ;; https://www.ecma-international.org/publications/files/ECMA-ST/ECMA-404.pdf ;; or https://tools.ietf.org/html/rfc7159#section-2 for the ;; definition of whitespace in JSON. - (inline-quote (skip-chars-forward "\t\r\n "))) + (inline-quote (skip-chars-forward "\t\n\r "))) @@ -227,6 +223,7 @@ Unlike `reverse', this keeps the property-value pairs intact." (define-error 'json-string-format "Bad string format" 'json-error) (define-error 'json-key-format "Bad JSON object key" 'json-error) (define-error 'json-object-format "Bad JSON object" 'json-error) +(define-error 'json-array-format "Bad JSON array" 'json-error) (define-error 'json-end-of-file "End of file while parsing JSON" '(end-of-file json-error)) @@ -235,8 +232,8 @@ Unlike `reverse', this keeps the property-value pairs intact." ;;; Paths (defvar json--path '() - "Used internally by `json-path-to-position' to keep track of -the path during recursive calls to `json-read'.") + "Keeps track of the path during recursive calls to `json-read'. +Used internally by `json-path-to-position'.") (defun json--record-path (key) "Record the KEY to the current JSON path. @@ -247,7 +244,7 @@ Used internally by `json-path-to-position'." "Check if the last parsed JSON structure passed POSITION. Used internally by `json-path-to-position'." (let ((start (caar json--path))) - (when (< start position (+ (point) 1)) + (when (< start position (1+ (point))) (throw :json-path (list :path (nreverse (mapcar #'cdr json--path)) :match-start start :match-end (point))))) @@ -265,13 +262,13 @@ properties: :path -- A list of strings and numbers forming the path to the JSON element at the given position. Strings denote object names, while numbers denote array - indexes. + indices. :match-start -- Position where the matched JSON element begins. :match-end -- Position where the matched JSON element ends. -This can for instance be useful to determine the path to a JSON +This can, for instance, be useful to determine the path to a JSON element in a deeply nested structure." (save-excursion (unless string @@ -279,7 +276,7 @@ element in a deeply nested structure." (let* ((json--path '()) (json-pre-element-read-function #'json--record-path) (json-post-element-read-function - (apply-partially #'json--check-position position)) + (lambda () (json--check-position position))) (path (catch :json-path (if string (json-read-from-string string) @@ -289,38 +286,33 @@ element in a deeply nested structure." ;;; Keywords -(defvar json-keywords '("true" "false" "null") +(defconst json-keywords '("true" "false" "null") "List of JSON keywords.") +(make-obsolete-variable 'json-keywords "it is no longer used." "28.1") ;; Keyword parsing +;; Characters that can follow a JSON value. +(rx-define json--post-value (| (in "\t\n\r ,]}") eos)) + (defun json-read-keyword (keyword) - "Read a JSON keyword at point. -KEYWORD is the keyword expected." - (unless (member keyword json-keywords) - (signal 'json-unknown-keyword (list keyword))) - (mapc (lambda (char) - (when (/= char (json-peek)) - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (json-advance)) - keyword) - (json-skip-whitespace) - (unless (looking-at "\\([],}]\\|$\\)") - (signal 'json-unknown-keyword - (list (save-excursion - (backward-word-strictly 1) - (thing-at-point 'word))))) - (cond ((string-equal keyword "true") t) - ((string-equal keyword "false") json-false) - ((string-equal keyword "null") json-null))) + "Read the expected JSON KEYWORD at point." + (prog1 (cond ((equal keyword "true") t) + ((equal keyword "false") json-false) + ((equal keyword "null") json-null) + (t (signal 'json-unknown-keyword (list keyword)))) + (or (looking-at-p keyword) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-advance (length keyword)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-unknown-keyword (list (thing-at-point 'word)))) + (json-skip-whitespace))) ;; Keyword encoding (defun json-encode-keyword (keyword) "Encode KEYWORD as a JSON value." + (declare (side-effect-free t)) (cond ((eq keyword t) "true") ((eq keyword json-false) "false") ((eq keyword json-null) "null"))) @@ -329,37 +321,31 @@ KEYWORD is the keyword expected." ;; Number parsing -(defun json-read-number (&optional sign) - "Read the JSON number following point. -The optional SIGN argument is for internal use. - -N.B.: Only numbers which can fit in Emacs Lisp's native number -representation will be parsed correctly." - ;; If SIGN is non-nil, the number is explicitly signed. - (let ((number-regexp - "\\([0-9]+\\)?\\(\\.[0-9]+\\)?\\([Ee][+-]?[0-9]+\\)?")) - (cond ((and (null sign) (= (json-peek) ?-)) - (json-advance) - (- (json-read-number t))) - ((and (null sign) (= (json-peek) ?+)) - (json-advance) - (json-read-number t)) - ((and (looking-at number-regexp) - (or (match-beginning 1) - (match-beginning 2))) - (goto-char (match-end 0)) - (string-to-number (match-string 0))) - (t (signal 'json-number-format (list (point))))))) +(rx-define json--number + (: (? ?-) ; Sign. + (| (: (in "1-9") (* digit)) ?0) ; Integer. + (? ?. (+ digit)) ; Fraction. + (? (in "Ee") (? (in ?+ ?-)) (+ digit)))) ; Exponent. + +(defun json-read-number (&optional _sign) + "Read the JSON number following point." + (declare (advertised-calling-convention () "28.1")) + (or (looking-at (rx json--number)) + (signal 'json-number-format (list (point)))) + (goto-char (match-end 0)) + (prog1 (string-to-number (match-string 0)) + (or (looking-at-p (rx json--post-value)) + (signal 'json-number-format (list (point)))) + (json-skip-whitespace))) ;; Number encoding -(defun json-encode-number (number) - "Return a JSON representation of NUMBER." - (format "%s" number)) +(defalias 'json-encode-number #'number-to-string + "Return a JSON representation of NUMBER.") ;;; Strings -(defvar json-special-chars +(defconst json-special-chars '((?\" . ?\") (?\\ . ?\\) (?b . ?\b) @@ -367,7 +353,7 @@ representation will be parsed correctly." (?n . ?\n) (?r . ?\r) (?t . ?\t)) - "Characters which are escaped in JSON, with their elisp counterparts.") + "Characters which are escaped in JSON, with their Elisp counterparts.") ;; String parsing @@ -377,48 +363,47 @@ representation will be parsed correctly." (defun json-read-escaped-char () "Read the JSON string escaped character at point." - ;; Skip over the '\' + ;; Skip over the '\'. (json-advance) - (let* ((char (json-pop)) - (special (assq char json-special-chars))) + (let ((char (json-pop))) (cond - (special (cdr special)) - ((not (eq char ?u)) char) + ((cdr (assq char json-special-chars))) + ((/= char ?u) char) ;; Special-case UTF-16 surrogate pairs, ;; cf. <https://tools.ietf.org/html/rfc7159#section-7>. Note that ;; this clause overlaps with the next one and therefore has to ;; come first. ((looking-at - (rx (group (any "Dd") (any "89ABab") (= 2 (any xdigit))) - "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 (any xdigit))))) + (rx (group (any "Dd") (any "89ABab") (= 2 xdigit)) + "\\u" (group (any "Dd") (any "C-Fc-f") (= 2 xdigit)))) (json-advance 10) (json--decode-utf-16-surrogates (string-to-number (match-string 1) 16) (string-to-number (match-string 2) 16))) ((looking-at (rx (= 4 xdigit))) - (let ((hex (match-string 0))) - (json-advance 4) - (string-to-number hex 16))) + (json-advance 4) + (string-to-number (match-string 0) 16)) (t (signal 'json-string-escape (list (point))))))) (defun json-read-string () "Read the JSON string at point." - (unless (= (json-peek) ?\") - (signal 'json-string-format (list "doesn't start with `\"'!"))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (let ((characters '()) (char (json-peek))) - (while (not (= char ?\")) + (while (/= char ?\") (when (< char 32) - (signal 'json-string-format (list (prin1-char char)))) + (if (zerop char) + (signal 'json-end-of-file ()) + (signal 'json-string-format (list char)))) (push (if (= char ?\\) (json-read-escaped-char) - (json-pop)) + (json-advance) + char) characters) (setq char (json-peek))) - ;; Skip over the '"' + ;; Skip over the '"'. (json-advance) (if characters (concat (nreverse characters)) @@ -426,29 +411,47 @@ representation will be parsed correctly." ;; String encoding +;; Escape only quotation mark, backslash, and the control +;; characters U+0000 to U+001F (RFC 4627, ECMA-404). +(rx-define json--escape (in ?\" ?\\ cntrl)) + +(defvar json--long-string-threshold 200 + "Length above which strings are considered long for JSON encoding. +It is generally faster to manipulate such strings in a buffer +rather than directly.") + +(defvar json--string-buffer nil + "Buffer used for encoding Lisp strings as JSON. +Initialized lazily by `json-encode-string'.") + (defun json-encode-string (string) "Return a JSON representation of STRING." - ;; Reimplement the meat of `replace-regexp-in-string', for - ;; performance (bug#20154). - (let ((l (length string)) - (start 0) - res mb) - ;; Only escape quotation mark, backslash and the control - ;; characters U+0000 to U+001F (RFC 4627, ECMA-404). - (while (setq mb (string-match "[\"\\[:cntrl:]]" string start)) - (let* ((c (aref string mb)) - (special (rassq c json-special-chars))) - (push (substring string start mb) res) - (push (if special - ;; Special JSON character (\n, \r, etc.). - (string ?\\ (car special)) - ;; Fallback: UCS code point in \uNNNN form. - (format "\\u%04x" c)) - res) - (setq start (1+ mb)))) - (push (substring string start l) res) - (push "\"" res) - (apply #'concat "\"" (nreverse res)))) + ;; Try to avoid buffer overhead in trivial cases, while also + ;; avoiding searching pathological strings for escape characters. + ;; Since `string-match-p' doesn't take a LIMIT argument, we use + ;; string length as our heuristic. See also bug#20154. + (if (and (< (length string) json--long-string-threshold) + (not (string-match-p (rx json--escape) string))) + (concat "\"" string "\"") + (with-current-buffer + (or json--string-buffer + (with-current-buffer (generate-new-buffer " *json-string*") + ;; This seems to afford decent performance gains. + (setq-local inhibit-modification-hooks t) + (setq json--string-buffer (current-buffer)))) + (insert ?\" string) + (goto-char (1+ (point-min))) + (while (re-search-forward (rx json--escape) nil 'move) + (let ((char (preceding-char))) + (delete-char -1) + (insert ?\\ (or + ;; Special JSON character (\n, \r, etc.). + (car (rassq char json-special-chars)) + ;; Fallback: UCS code point in \uNNNN form. + (format "u%04x" char))))) + (insert ?\") + ;; Empty buffer for next invocation. + (delete-and-extract-region (point-min) (point-max))))) (defun json-encode-key (object) "Return a JSON representation of OBJECT. @@ -459,15 +462,13 @@ this signals `json-key-format'." (signal 'json-key-format (list object))) encoded)) -;;; JSON Objects +;;; Objects (defun json-new-object () - "Create a new Elisp object corresponding to a JSON object. + "Create a new Elisp object corresponding to an empty JSON object. Please see the documentation of `json-object-type'." - (cond ((eq json-object-type 'hash-table) - (make-hash-table :test 'equal)) - (t - ()))) + (and (eq json-object-type 'hash-table) + (make-hash-table :test #'equal))) (defun json-add-to-object (object key value) "Add a new KEY -> VALUE association to OBJECT. @@ -475,10 +476,10 @@ Returns the updated object, which you should save, e.g.: (setq obj (json-add-to-object obj \"foo\" \"bar\")) Please see the documentation of `json-object-type' and `json-key-type'." (let ((json-key-type - (or json-key-type - (cdr (assq json-object-type '((hash-table . string) - (alist . symbol) - (plist . keyword))))))) + (cond (json-key-type) + ((eq json-object-type 'hash-table) 'string) + ((eq json-object-type 'alist) 'symbol) + ((eq json-object-type 'plist) 'keyword)))) (setq key (cond ((eq json-key-type 'string) key) @@ -498,13 +499,13 @@ Please see the documentation of `json-object-type' and `json-key-type'." (defun json-read-object () "Read the JSON object at point." - ;; Skip over the "{" + ;; Skip over the '{'. (json-advance) (json-skip-whitespace) - ;; read key/value pairs until "}" + ;; Read key/value pairs until '}'. (let ((elements (json-new-object)) key value) - (while (not (= (json-peek) ?})) + (while (/= (json-peek) ?\}) (json-skip-whitespace) (setq key (json-read-string)) (json-skip-whitespace) @@ -519,94 +520,94 @@ Please see the documentation of `json-object-type' and `json-key-type'." (funcall json-post-element-read-function)) (setq elements (json-add-to-object elements key value)) (json-skip-whitespace) - (when (/= (json-peek) ?}) + (when (/= (json-peek) ?\}) (if (= (json-peek) ?,) (json-advance) (signal 'json-object-format (list "," (json-peek)))))) - ;; Skip over the "}" + ;; Skip over the '}'. (json-advance) (pcase json-object-type ('alist (nreverse elements)) - ('plist (json--plist-reverse elements)) + ('plist (json--plist-nreverse elements)) (_ elements)))) ;; Hash table encoding (defun json-encode-hash-table (hash-table) "Return a JSON representation of HASH-TABLE." - (if json-encoding-object-sort-predicate - (json-encode-alist (map-into hash-table 'list)) - (format "{%s%s}" - (json-join - (let (r) - (json--with-indentation - (maphash - (lambda (k v) - (push (format - (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key k) - (json-encode v)) - r)) - hash-table)) - r) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation)))) + (cond ((hash-table-empty-p hash-table) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs hash-table) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) + result) + (json--with-indentation + (maphash + (lambda (k v) + (push (concat json--encoding-current-indentation + (json-encode-key k) + kv-sep + (json-encode v)) + result)) + hash-table)) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) ;; List encoding (including alists and plists) -(defun json-encode-alist (alist) - "Return a JSON representation of ALIST." +(defun json--encode-alist (alist &optional destructive) + "Return a JSON representation of ALIST. +DESTRUCTIVE non-nil means it is safe to modify ALIST by +side-effects." (when json-encoding-object-sort-predicate - (setq alist - (sort alist (lambda (a b) + (setq alist (sort (if destructive alist (copy-sequence alist)) + (lambda (a b) (funcall json-encoding-object-sort-predicate (car a) (car b)))))) - (format "{%s%s}" - (json-join - (json--with-indentation - (mapcar (lambda (cons) - (format (if json-encoding-pretty-print - "%s%s: %s" - "%s%s:%s") - json--encoding-current-indentation - (json-encode-key (car cons)) - (json-encode (cdr cons)))) - alist)) - json-encoding-separator) - (if (or (not json-encoding-pretty-print) - json-encoding-lisp-style-closings) - "" - json--encoding-current-indentation))) + (concat "{" + (let ((kv-sep (if json-encoding-pretty-print ": " ":"))) + (json--with-indentation + (mapconcat (lambda (cons) + (concat json--encoding-current-indentation + (json-encode-key (car cons)) + kv-sep + (json-encode (cdr cons)))) + alist + json-encoding-separator))) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}")) + +(defun json-encode-alist (alist) + "Return a JSON representation of ALIST." + (if alist (json--encode-alist alist) "{}")) (defun json-encode-plist (plist) "Return a JSON representation of PLIST." - (if json-encoding-object-sort-predicate - (json-encode-alist (json--plist-to-alist plist)) - (let (result) - (json--with-indentation - (while plist - (push (concat - json--encoding-current-indentation - (json-encode-key (car plist)) - (if json-encoding-pretty-print - ": " - ":") - (json-encode (cadr plist))) + (cond ((null plist) "{}") + (json-encoding-object-sort-predicate + (json--encode-alist (map-pairs plist) t)) + (t + (let ((kv-sep (if json-encoding-pretty-print ": " ":")) result) - (setq plist (cddr plist)))) - (concat "{" - (json-join (nreverse result) json-encoding-separator) - (if (and json-encoding-pretty-print - (not json-encoding-lisp-style-closings)) - json--encoding-current-indentation - "") - "}")))) + (json--with-indentation + (while plist + (push (concat json--encoding-current-indentation + (json-encode-key (pop plist)) + kv-sep + (json-encode (pop plist))) + result))) + (concat "{" + (string-join (nreverse result) json-encoding-separator) + (and json-encoding-pretty-print + (not json-encoding-lisp-style-closings) + json--encoding-current-indentation) + "}"))))) (defun json-encode-list (list) "Return a JSON representation of LIST. @@ -624,15 +625,17 @@ become JSON objects." (defun json-read-array () "Read the JSON array at point." - ;; Skip over the "[" + ;; Skip over the '['. (json-advance) (json-skip-whitespace) - ;; read values until "]" - (let (elements) - (while (not (= (json-peek) ?\])) + ;; Read values until ']'. + (let (elements + (len 0)) + (while (/= (json-peek) ?\]) (json-skip-whitespace) (when json-pre-element-read-function - (funcall json-pre-element-read-function (length elements))) + (funcall json-pre-element-read-function len) + (setq len (1+ len))) (push (json-read) elements) (when json-post-element-read-function (funcall json-post-element-read-function)) @@ -640,8 +643,8 @@ become JSON objects." (when (/= (json-peek) ?\]) (if (= (json-peek) ?,) (json-advance) - (signal 'json-error (list 'bleah))))) - ;; Skip over the "]" + (signal 'json-array-format (list "," (json-peek)))))) + ;; Skip over the ']'. (json-advance) (pcase json-array-type ('vector (nreverse (vconcat elements))) @@ -652,42 +655,43 @@ become JSON objects." (defun json-encode-array (array) "Return a JSON representation of ARRAY." (if (and json-encoding-pretty-print - (> (length array) 0)) + (not (seq-empty-p array))) (concat + "[" (json--with-indentation - (concat (format "[%s" json--encoding-current-indentation) - (json-join (mapcar 'json-encode array) - (format "%s%s" - json-encoding-separator + (concat json--encoding-current-indentation + (mapconcat #'json-encode array + (concat json-encoding-separator json--encoding-current-indentation)))) - (format "%s]" - (if json-encoding-lisp-style-closings - "" - json--encoding-current-indentation))) + (unless json-encoding-lisp-style-closings + json--encoding-current-indentation) + "]") (concat "[" - (mapconcat 'json-encode array json-encoding-separator) + (mapconcat #'json-encode array json-encoding-separator) "]"))) -;;; JSON reader. +;;; Reader (defmacro json-readtable-dispatch (char) - "Dispatch reader function for CHAR." - (declare (debug (symbolp))) - (let ((table - '((?t json-read-keyword "true") - (?f json-read-keyword "false") - (?n json-read-keyword "null") - (?{ json-read-object) - (?\[ json-read-array) - (?\" json-read-string))) - res) - (dolist (c '(?- ?+ ?. ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)) - (push (list c 'json-read-number) table)) - (pcase-dolist (`(,c . ,rest) table) - (push `((eq ,char ,c) (,@rest)) res)) - `(cond ,@res (t (signal 'json-readtable-error (list ,char)))))) + "Dispatch reader function for CHAR at point. +If CHAR is nil, signal `json-end-of-file'." + (declare (debug t)) + (macroexp-let2 nil char char + `(cond ,@(map-apply + (lambda (key expr) + `((eq ,char ,key) ,expr)) + `((?\" ,#'json-read-string) + (?\[ ,#'json-read-array) + (?\{ ,#'json-read-object) + (?n ,#'json-read-keyword "null") + (?f ,#'json-read-keyword "false") + (?t ,#'json-read-keyword "true") + ,@(mapcar (lambda (c) (list c #'json-read-number)) + '(?- ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9)))) + (,char (signal 'json-readtable-error (list ,char))) + (t (signal 'json-end-of-file ()))))) (defun json-read () "Parse and return the JSON object following point. @@ -705,10 +709,7 @@ you will get the following structure returned: ((c . :json-false))]) (b . \"foo\"))" (json-skip-whitespace) - (let ((char (json-peek))) - (if (zerop char) - (signal 'json-end-of-file nil) - (json-readtable-dispatch char)))) + (json-readtable-dispatch (char-after))) ;; Syntactic sugar for the reader @@ -723,12 +724,11 @@ you will get the following structure returned: "Read the first JSON object contained in FILE and return it." (with-temp-buffer (insert-file-contents file) - (goto-char (point-min)) (json-read))) -;;; JSON encoder +;;; Encoder (defun json-encode (object) "Return a JSON representation of OBJECT as a string. @@ -736,20 +736,21 @@ you will get the following structure returned: OBJECT should have a structure like one returned by `json-read'. If an error is detected during encoding, an error based on `json-error' is signaled." - (cond ((memq object (list t json-null json-false)) - (json-encode-keyword object)) - ((stringp object) (json-encode-string object)) - ((keywordp object) (json-encode-string - (substring (symbol-name object) 1))) - ((listp object) (json-encode-list object)) - ((symbolp object) (json-encode-string - (symbol-name object))) - ((numberp object) (json-encode-number object)) - ((arrayp object) (json-encode-array object)) - ((hash-table-p object) (json-encode-hash-table object)) - (t (signal 'json-error (list object))))) - -;; Pretty printing & minimizing + (cond ((eq object t) (json-encode-keyword object)) + ((eq object json-null) (json-encode-keyword object)) + ((eq object json-false) (json-encode-keyword object)) + ((stringp object) (json-encode-string object)) + ((keywordp object) (json-encode-string + (substring (symbol-name object) 1))) + ((listp object) (json-encode-list object)) + ((symbolp object) (json-encode-string + (symbol-name object))) + ((numberp object) (json-encode-number object)) + ((arrayp object) (json-encode-array object)) + ((hash-table-p object) (json-encode-hash-table object)) + (t (signal 'json-error (list object))))) + +;;; Pretty printing & minimizing (defun json-pretty-print-buffer (&optional minimize) "Pretty-print current buffer. @@ -768,9 +769,9 @@ MAX-SECS.") With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") (let ((json-encoding-pretty-print (null minimize)) - ;; Distinguish an empty objects from 'null' + ;; Distinguish an empty object from 'null'. (json-null :json-null) - ;; Ensure that ordering is maintained + ;; Ensure that ordering is maintained. (json-object-type 'alist) (orig-buf (current-buffer)) error) @@ -799,9 +800,7 @@ With prefix argument MINIMIZE, minimize it instead." ;; them. (let ((space (buffer-substring (point) - (+ (point) - (skip-chars-forward - " \t\n" (point-max))))) + (+ (point) (skip-chars-forward " \t\n")))) (json (json-read))) (setq pos (point)) ; End of last good json-read. (set-buffer tmp-buf) @@ -831,14 +830,14 @@ With prefix argument MINIMIZE, minimize it instead." "Pretty-print current buffer with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "P") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print-buffer minimize))) (defun json-pretty-print-ordered (begin end &optional minimize) "Pretty-print the region with object keys ordered. With prefix argument MINIMIZE, minimize it instead." (interactive "r\nP") - (let ((json-encoding-object-sort-predicate 'string<)) + (let ((json-encoding-object-sort-predicate #'string<)) (json-pretty-print begin end minimize))) (provide 'json) diff --git a/lisp/jsonrpc.el b/lisp/jsonrpc.el index 65c0df8f57c..ff8f250a22e 100644 --- a/lisp/jsonrpc.el +++ b/lisp/jsonrpc.el @@ -4,11 +4,11 @@ ;; Author: João Távora <joaotavora@gmail.com> ;; Keywords: processes, languages, extensions +;; Version: 1.0.12 ;; Package-Requires: ((emacs "25.2")) -;; Version: 1.0.9 -;; This is an Elpa :core package. Don't use functionality that is not -;; compatible with Emacs 25.2. +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This program is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by @@ -37,7 +37,6 @@ ;;; Code: (require 'cl-lib) -(require 'json) (require 'eieio) (eval-when-compile (require 'subr-x)) (require 'warnings) @@ -364,21 +363,53 @@ connection object, called when the process dies .") (cl-defmethod initialize-instance ((conn jsonrpc-process-connection) slots) (cl-call-next-method) - (let* ((proc (plist-get slots :process)) - (proc (if (functionp proc) (funcall proc) proc)) - (buffer (get-buffer-create (format "*%s output*" (process-name proc)))) - (stderr (get-buffer-create (format "*%s stderr*" (process-name proc))))) + (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 + ;; calling `make-process'. If there were a `set-process-stderr' + ;; like there is `set-process-buffer' we wouldn't need this and + ;; could use a pipe with a process filter instead of + ;; `after-change-functions'. Alternatively, we need a new initarg + ;; (but maybe not a slot). + (let ((calling-buffer (current-buffer))) + (with-current-buffer (get-buffer-create (format "*%s stderr*" name)) + (let ((inhibit-read-only t) + (hidden-name (concat " " (buffer-name)))) + (erase-buffer) + (buffer-disable-undo) + (add-hook + 'after-change-functions + (lambda (beg _end _pre-change-len) + (cl-loop initially (goto-char beg) + do (forward-line) + when (bolp) + for line = (buffer-substring + (line-beginning-position 0) + (line-end-position 0)) + do (with-current-buffer (jsonrpc-events-buffer conn) + (goto-char (point-max)) + (let ((inhibit-read-only t)) + (insert (format "[stderr] %s\n" line)))) + until (eobp))) + nil t) + ;; If we are correctly coupled to the client, the process + ;; now created should pick up the current stderr buffer, + ;; which we immediately rename + (setq proc (if (functionp proc) + (with-current-buffer calling-buffer (funcall proc)) + proc)) + (ignore-errors (kill-buffer hidden-name)) + (rename-buffer hidden-name) + (process-put proc 'jsonrpc-stderr (current-buffer)) + (read-only-mode t)))) (setf (jsonrpc--process conn) proc) - (set-process-buffer proc buffer) - (process-put proc 'jsonrpc-stderr stderr) + (set-process-buffer proc (get-buffer-create (format " *%s output*" name))) (set-process-filter proc #'jsonrpc--process-filter) (set-process-sentinel proc #'jsonrpc--process-sentinel) (with-current-buffer (process-buffer proc) (buffer-disable-undo) (set-marker (process-mark proc) (point-min)) - (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t) proc)) - (with-current-buffer stderr - (buffer-disable-undo)) + (let ((inhibit-read-only t)) (erase-buffer) (read-only-mode t))) (process-put proc 'jsonrpc-connection conn))) (cl-defmethod jsonrpc-connection-send ((connection jsonrpc-process-connection) @@ -442,26 +473,35 @@ With optional CLEANUP, kill any associated buffers." ;;; (define-error 'jsonrpc-error "jsonrpc-error") -(defun jsonrpc--json-read () - "Read JSON object in buffer, move point to end of buffer." - ;; TODO: I guess we can make these macros if/when jsonrpc.el - ;; goes into Emacs core. - (cond ((fboundp 'json-parse-buffer) (json-parse-buffer - :object-type 'plist - :null-object nil - :false-object :json-false)) - (t (let ((json-object-type 'plist)) - (json-read))))) - -(defun jsonrpc--json-encode (object) - "Encode OBJECT into a JSON string." - (cond ((fboundp 'json-serialize) (json-serialize - object - :false-object :json-false - :null-object nil)) - (t (let ((json-false :json-false) - (json-null nil)) - (json-encode object))))) +(defalias 'jsonrpc--json-read + (if (fboundp 'json-parse-buffer) + (lambda () + (json-parse-buffer :object-type 'plist + :null-object nil + :false-object :json-false)) + (require 'json) + (defvar json-object-type) + (declare-function json-read "json" ()) + (lambda () + (let ((json-object-type 'plist)) + (json-read)))) + "Read JSON object in buffer, move point to end of buffer.") + +(defalias 'jsonrpc--json-encode + (if (fboundp 'json-serialize) + (lambda (object) + (json-serialize object + :false-object :json-false + :null-object nil)) + (require 'json) + (defvar json-false) + (defvar json-null) + (declare-function json-encode "json" (object)) + (lambda (object) + (let ((json-false :json-false) + (json-null nil)) + (json-encode object)))) + "Encode OBJECT into a JSON string.") (cl-defun jsonrpc--reply (connection id &key (result nil result-supplied-p) (error nil error-supplied-p)) @@ -682,7 +722,7 @@ originated." (format "-%s" subtype))))) (goto-char (point-max)) (prog1 - (let ((msg (format "%s%s%s %s:\n%s\n" + (let ((msg (format "[%s]%s%s %s:\n%s" type (if id (format " (id:%s)" id) "") (if error " ERROR" "") diff --git a/lisp/kermit.el b/lisp/kermit.el index b0a4d90932e..f2607bfcf4c 100644 --- a/lisp/kermit.el +++ b/lisp/kermit.el @@ -1,4 +1,4 @@ -;;; kermit.el --- additions to shell mode for use with kermit +;;; kermit.el --- additions to shell mode for use with kermit -*- lexical-binding: t -*- ;; Copyright (C) 1988, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/language/chinese.el b/lisp/language/chinese.el index bc6969c1398..4389db961d8 100644 --- a/lisp/language/chinese.el +++ b/lisp/language/chinese.el @@ -103,6 +103,11 @@ (define-coding-system-alias 'hz-gb-2312 'chinese-hz) (define-coding-system-alias 'hz 'chinese-hz) +;; FIXME: 'define-coding-system' automatically sets :ascii-compatible-p, +;; to any encoding whose :coding-type is 'utf-8', but UTF-7 is not ASCII +;; compatible, so we override that here (bug#40407). +(coding-system-put 'chinese-hz :ascii-compatible-p nil) + (set-language-info-alist "Chinese-GB" '((charset chinese-gb2312 chinese-sisheng) (iso639-language . zh) diff --git a/lisp/language/hebrew.el b/lisp/language/hebrew.el index 573541aec16..08b70abfc29 100644 --- a/lisp/language/hebrew.el +++ b/lisp/language/hebrew.el @@ -240,7 +240,7 @@ Bidirectional editing is supported."))) (let* ((base "[\u05D0-\u05F2\uFB1D\uFB1F-\uFB28\uFB2A-\uFB4F]") (combining - "[\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+") + "[\u034F\u0591-\u05BD\u05BF\u05C1-\u05C2\u05C4-\u05C5\u05C7\uFB1E]+") (pattern1 (concat base combining)) (pattern2 (concat base "\u200D" combining))) (set-char-table-range diff --git a/lisp/language/ind-util.el b/lisp/language/ind-util.el index 4319e5537e7..62885227f10 100644 --- a/lisp/language/ind-util.el +++ b/lisp/language/ind-util.el @@ -232,8 +232,8 @@ '( (;; VOWELS (?അ nil) (?ആ ?ാ) (?ഇ ?ി) (?ഈ ?ീ) (?ഉ ?ു) (?ഊ ?ൂ) - (?ഋ ?ൃ) (?ഌ nil) nil (?ഏ ?േ) (?എ ?െ) (?ഐ ?ൈ) - nil (?ഓ ?ോ) (?ഒ ?ൊ) (?ഔ ?ൌ) nil nil) + (?ഋ ?ൃ) (?ഌ ?ൢ) (?ൡ ?ൣ) (?ഏ ?േ) (?എ ?െ) (?ഐ ?ൈ) + nil (?ഒ ?ൊ) (?ഓ ?ോ) (?ഔ ?ൗ) (?് ?്) (?ൠ ?ൄ)) (;; CONSONANTS ?ക ?ഖ ?ഗ ?ഘ ?ങ ;; GUTTRULS ?ച ?ഛ ?ജ ?ഝ ?ഞ ;; PALATALS @@ -243,13 +243,16 @@ ?യ ?ര ?റ ?ല ?ള ?ഴ ?വ ;; SEMIVOWELS ?ശ ?ഷ ?സ ?ഹ ;; SIBILANTS nil nil nil nil nil nil nil nil ;; NUKTAS - "ജ്ഞ" "ക്ഷ") + "ജ്ഞ" "ക്ഷ" + "റ്റ" "ന്റ" "ത്ത" "ത്ഥ" "ഞ്ഞ" "ങ്ങ" "ന്ന" + "ഞ്ച" "ന്ക" "ങ്ക" "ച്ച" "ച്ഛ" "ക്ക" + "ബ്ബ" "ക്ക" "ഗ്ഗ" "ജ്ജ" "മ്മ" "പ്പ" "വ്വ" "ക്സ" "ശ്ശ") (;; Misc Symbols nil ?ം ?ഃ nil ?് nil nil) (;; Digits ?൦ ?൧ ?൨ ?൩ ?൪ ?൫ ?൬ ?൭ ?൮ ?൯) - (;; Inscript-extra (4) (#, $, ^, *, ]) - "്ര" "ര്" "ത്ര" "ശ്ര" nil))) + (;; Chillus + "ണ്" ?ൺ "ന്" ?ൻ "ര്" ?ർ "ല്" ?ൽ "ള്" ?ൾ))) (defvar indian-tml-base-table '( @@ -323,6 +326,29 @@ (;; misc -- 7 ".N" (".n" "M") "H" ".a" ".h" ("AUM" "OM") ".."))) +(defvar indian-mlm-mozhi-table + '(;; for encode/decode + (;; vowels -- 18 + "a" ("aa" "A") "i" ("ii" "I") "u" ("uu" "U") + "R" "Ll" "Lll" ("E" "ae") "e" "ai" + nil "o" "O" "au" "~" "RR") + (;; consonants -- 40 + ("k" "c") "kh" "g" "gh" "ng" + "ch" ("Ch" "chh") "j" "jh" "nj" + "T" "Th" "D" "Dh" "N" + "th" "thh" "d" "dh" "n" nil + "p" ("ph" "f") "b" "bh" "m" + "y" "r" "rr" "l" "L" "zh" ("v" "w") + ("S" "z") "sh" "s" "h" + nil nil nil nil nil nil nil nil + nil "X" + ;; some of these are extra to Mozhi + ("t" "tt") "nt" "tth" "tthh" "nnj" "nng" "nn" + "nch" "nc" "nk" "cch" "cchh" "cc" + "B" ("C" "K" "q") "G" "J" "M" "P" "V" "x" "Z") + (;; misc -- 7 + nil nil "H"))) + (defvar indian-kyoto-harvard-table '(;; for encode/decode (;; vowel @@ -524,6 +550,10 @@ (indian-make-hash indian-mlm-base-table indian-itrans-v5-table)) +(defvar indian-mlm-mozhi-hash + (indian-make-hash indian-mlm-base-table + indian-mlm-mozhi-table)) + (defvar indian-tml-itrans-v5-hash (indian-make-hash indian-tml-base-table indian-itrans-v5-table-for-tamil)) diff --git a/lisp/language/japanese.el b/lisp/language/japanese.el index d77efa48c9b..9a99245dfde 100644 --- a/lisp/language/japanese.el +++ b/lisp/language/japanese.el @@ -82,9 +82,7 @@ (#x00A6 . #xFFE4) ; BROKEN LINE FULLWIDTH BROKEN LINE ))) (define-translation-table 'japanese-ucs-jis-to-cp932-map map) - (mapc #'(lambda (x) (let ((tmp (car x))) - (setcar x (cdr x)) (setcdr x tmp))) - map) + (setq map (mapcar (lambda (x) (cons (cdr x) (car x))) map)) (define-translation-table 'japanese-ucs-cp932-to-jis-map map)) ;; U+2014 (EM DASH) vs U+2015 (HORIZONTAL BAR) @@ -241,8 +239,10 @@ eucJP-ms is defined in <http://www.opengroup.or.jp/jvc/cde/appendix.html>." (#x2b65 . [#x02E9 #x02E5]) (#x2b66 . [#x02E5 #x02E9]))) table) - (dolist (elt map) - (setcar elt (decode-char 'japanese-jisx0213-1 (car elt)))) + (setq map + (mapcar (lambda (x) (cons (decode-char 'japanese-jisx0213-1 (car x)) + (cdr x))) + map)) (setq table (make-translation-table-from-alist map)) (define-translation-table 'jisx0213-to-unicode table) (define-translation-table 'unicode-to-jisx0213 diff --git a/lisp/language/korean.el b/lisp/language/korean.el index 210d0fabaf7..7e758159a48 100644 --- a/lisp/language/korean.el +++ b/lisp/language/korean.el @@ -84,6 +84,18 @@ and the following key bindings are available within Korean input methods: F9, Hangul_Hanja: hangul-to-hanja-conversion") )) +;; For auto-composing conjoining jamo. +(let* ((choseong "[\u1100-\u115F\uA960-\uA97C]") + (jungseong "[\u1160-\u11A7\uD7B0-\uD7C6]") + (jongseong "[\u11A8-\u11FF\uD7CB-\uD7FB]?") + (pattern (concat choseong jungseong jongseong))) + (set-char-table-range composition-function-table + '(#x1100 . #x115F) + (list (vector pattern 0 'font-shape-gstring))) + (set-char-table-range composition-function-table + '(#xA960 . #xA97C) + (list (vector pattern 0 'font-shape-gstring)))) + (provide 'korean) ;;; korean.el ends here diff --git a/lisp/language/lao-util.el b/lisp/language/lao-util.el index a20aecee421..fa4c2f7f891 100644 --- a/lisp/language/lao-util.el +++ b/lisp/language/lao-util.el @@ -183,7 +183,9 @@ ;; Semi-vowel-sign-lo and lower vowels are put under the letter. (defconst lao-transcription-consonant-alist - (sort '(;; single consonants + (sort + (copy-sequence + '(;; single consonants ("k" . "ກ") ("kh" . "ຂ") ("qh" . "ຄ") @@ -223,14 +225,16 @@ ("hy" . ["ຫຍ"]) ("hn" . ["ຫນ"]) ("hm" . ["ຫມ"]) - ) - (function (lambda (x y) (> (length (car x)) (length (car y))))))) + )) + (lambda (x y) (> (length (car x)) (length (car y)))))) (defconst lao-transcription-semi-vowel-alist '(("r" . "ຼ"))) (defconst lao-transcription-vowel-alist - (sort '(("a" . "ະ") + (sort + (copy-sequence + '(("a" . "ະ") ("ar" . "າ") ("i" . "ິ") ("ii" . "ີ") @@ -257,8 +261,8 @@ ("ai" . "ໄ") ("ei" . "ໃ") ("ao" . ["ເົາ"]) - ("aM" . "ຳ")) - (function (lambda (x y) (> (length (car x)) (length (car y))))))) + ("aM" . "ຳ"))) + (lambda (x y) (> (length (car x)) (length (car y)))))) ;; Maa-sakod is put at the tail. (defconst lao-transcription-maa-sakod-alist diff --git a/lisp/language/misc-lang.el b/lisp/language/misc-lang.el index e25e63b4c5c..e3a24c41536 100644 --- a/lisp/language/misc-lang.el +++ b/lisp/language/misc-lang.el @@ -136,10 +136,10 @@ thin (i.e. 1-dot width) space." (set-char-table-range composition-function-table '(#x600 . #x74F) - (list (vector "[\u0600-\u074F\u200C\u200D]+" 0 - 'arabic-shape-gstring) - (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" 1 - 'arabic-shape-gstring))) + (list (vector "[\u200C\u200D][\u0600-\u074F\u200C\u200D]+" + 1 'arabic-shape-gstring) + (vector "[\u0600-\u074F\u200C\u200D]+" + 0 'arabic-shape-gstring))) (provide 'misc-lang) diff --git a/lisp/language/tibet-util.el b/lisp/language/tibet-util.el index 29fff9175b7..8684cdb1338 100644 --- a/lisp/language/tibet-util.el +++ b/lisp/language/tibet-util.el @@ -43,13 +43,17 @@ ("་" . "་") ("༔" . "༔") ;; Yes these are dirty. But ... - ("༎ ༎" . ,(compose-string "༎ ༎" 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) + ("༎ ༎" . ,(compose-string (copy-sequence "༎ ༎") + 0 3 [?༎ (Br . Bl) ? (Br . Bl) ?༎])) ("༄༅༅" . ,(compose-string - "࿁࿂࿂࿂" 0 4 + (copy-sequence "࿁࿂࿂࿂") 0 4 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) - ("༄༅" . ,(compose-string "࿁࿂࿂" 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) - ("༆" . ,(compose-string "࿁࿂༙" 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙])) - ("༄" . ,(compose-string "࿁࿂" 0 2 [?࿁ (Br . Bl) ?࿂])))) + ("༄༅" . ,(compose-string (copy-sequence "࿁࿂࿂") + 0 3 [?࿁ (Br . Bl) ?࿂ (Br . Bl) ?࿂])) + ("༆" . ,(compose-string (copy-sequence "࿁࿂༙") + 0 3 [?࿁ (Br . Bl) ?࿂ (br . tr) ?༙])) + ("༄" . ,(compose-string (copy-sequence "࿁࿂") + 0 2 [?࿁ (Br . Bl) ?࿂])))) ;;;###autoload (defun tibetan-char-p (ch) diff --git a/lisp/language/tibetan.el b/lisp/language/tibetan.el index d31cd5cd528..bbd4729f6c5 100644 --- a/lisp/language/tibetan.el +++ b/lisp/language/tibetan.el @@ -326,7 +326,9 @@ (defconst tibetan-subjoined-transcription-alist - (sort '(("+k" . "ྐ") + (sort + (copy-sequence + '(("+k" . "ྐ") ("+kh" . "ྑ") ("+g" . "ྒ") ("+gh" . "ྒྷ") @@ -371,8 +373,8 @@ ("+W" . "ྺ") ;; fixed form subscribed WA ("+Y" . "ྻ") ;; fixed form subscribed YA ("+R" . "ྼ") ;; fixed form subscribed RA - ) - (lambda (x y) (> (length (car x)) (length (car y)))))) + )) + (lambda (x y) (> (length (car x)) (length (car y)))))) ;;; ;;; alist for Tibetan base consonant <-> subjoined consonant conversion. diff --git a/lisp/ldefs-boot.el b/lisp/ldefs-boot.el index a8e1ed8f8d1..bcd8e0d5083 100644 --- a/lisp/ldefs-boot.el +++ b/lisp/ldefs-boot.el @@ -1076,7 +1076,7 @@ search for matches for any two (or more) of those words. With \\[universal-argument] prefix, or if `apropos-do-all' is non-nil, consider all symbols (if they match PATTERN). -Returns list of symbols and documentation found. +Return list of symbols and documentation found. \(fn PATTERN &optional DO-ALL)" t nil) @@ -2452,16 +2452,34 @@ Function to display the current buffer in a WWW browser. This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'.") +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'.") (custom-autoload 'browse-url-browser-function "browse-url" t) +(defvar browse-url-default-handlers '(("\\`mailto:" . browse-url--mailto) ("\\`man:" . browse-url--man) (browse-url--non-html-file-url-p . browse-url-emacs)) "\ +Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(autoload 'browse-url-select-handler "browse-url" "\ +Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release. + +\(fn URL &optional KIND)" nil nil) + (autoload 'browse-url-of-file "browse-url" "\ Ask a WWW browser to display FILE. Display the current buffer's file if FILE is nil or if called @@ -2491,16 +2509,18 @@ Ask a WWW browser to display the current region. Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS. +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS. \(fn URL &rest ARGS)" t nil) @@ -2512,6 +2532,15 @@ Optional prefix argument ARG non-nil inverts the value of the option \(fn &optional ARG)" t nil) +(autoload 'browse-url-with-browser-kind "browse-url" "\ +Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'. + +\(fn KIND URL &optional ARG)" t nil) + (autoload 'browse-url-at-mouse "browse-url" "\ Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -2699,6 +2728,8 @@ NEW-WINDOW instead of `browse-url-new-window-flag'. \(fn URL &optional NEW-WINDOW)" t nil) +(make-obsolete 'browse-url-conkeror 'nil '"28.1") + (autoload 'browse-url-w3 "browse-url" "\ Ask the w3 WWW browser to load URL. Default to the URL around or before point. @@ -3674,7 +3705,7 @@ Return the syntactic context of the current line." nil nil) ;;;### (autoloads nil "cc-fonts" "progmodes/cc-fonts.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cc-fonts.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cc-fonts" '("autodoc-" "c++-font-lock-keywords" "c-" "doxygen-font-lock-" "gtkdoc-font-lock-" "idl-font-lock-keywords" "java" "objc-font-lock-keywords" "pike-font-lock-keywords"))) ;;;*** @@ -3843,7 +3874,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable -`c-mode' or `c++-mode'." nil nil) +`c-mode' or `c++-mode'." t nil) (autoload 'c++-mode "cc-mode" "\ Major mode for editing C++ code. @@ -4480,7 +4511,6 @@ Returns non-nil if any false statements are found. ;;;### (autoloads nil "checkdoc" "emacs-lisp/checkdoc.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from emacs-lisp/checkdoc.el -(push (purecopy '(checkdoc 0 6 2)) package--builtin-versions) (put 'checkdoc-force-docstrings-flag 'safe-local-variable #'booleanp) (put 'checkdoc-force-history-flag 'safe-local-variable #'booleanp) (put 'checkdoc-permit-comma-termination-flag 'safe-local-variable #'booleanp) @@ -4746,6 +4776,34 @@ and runs the normal hook `command-history-hook'." t nil) ;;;*** +;;;### (autoloads nil "cl-font-lock" "progmodes/cl-font-lock.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from progmodes/cl-font-lock.el + +(defvar cl-font-lock-built-in-mode nil "\ +Non-nil if Cl-Font-Lock-Built-In mode is enabled. +See the `cl-font-lock-built-in-mode' command +for a description of this minor mode. +Setting this variable directly does not take effect; +either customize it (see the info node `Easy Customization') +or call the function `cl-font-lock-built-in-mode'.") + +(custom-autoload 'cl-font-lock-built-in-mode "cl-font-lock" nil) + +(autoload 'cl-font-lock-built-in-mode "cl-font-lock" "\ +Highlight built-in functions, variables, and types in `lisp-mode'. + +If called interactively, enable Cl-Font-Lock-Built-In mode if ARG is +positive, and disable it if ARG is zero or negative. If called from +Lisp, also enable the mode if ARG is omitted or nil, and toggle it if +ARG is `toggle'; disable the mode otherwise. + +\(fn &optional ARG)" t nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "cl-font-lock" '("cl-font-lock-"))) + +;;;*** + ;;;### (autoloads nil "cl-generic" "emacs-lisp/cl-generic.el" (0 ;;;;;; 0 0 0)) ;;; Generated autoloads from emacs-lisp/cl-generic.el @@ -5492,7 +5550,9 @@ doesn't have enough contents to decide, this is identical to See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', `conf-ppd-mode' and `conf-xdefaults-mode'. -\\{conf-mode-map}" t nil) +\\{conf-mode-map} + +\(fn)" t nil) (autoload 'conf-unix-mode "conf-mode" "\ Conf Mode starter for Unix style Conf files. @@ -6469,7 +6529,6 @@ Mode used for cvs status output. ;;;### (autoloads nil "cwarn" "progmodes/cwarn.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/cwarn.el -(push (purecopy '(cwarn 1 3 1)) package--builtin-versions) (autoload 'cwarn-mode "cwarn" "\ Minor mode that highlights suspicious C and C++ constructions. @@ -6607,7 +6666,7 @@ Create a new data-debug buffer with NAME. \(fn NAME)" nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-" "dd-propertize"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "data-debug" '("data-debug-"))) ;;;*** @@ -7635,7 +7694,6 @@ Hooks (use \\[describe-variable] to see their documentation): `dired-before-readin-hook' `dired-after-readin-hook' `dired-mode-hook' - `dired-load-hook' Keybindings: \\{dired-mode-map} @@ -8975,7 +9033,7 @@ an EDE controlled project. ;;;;;; "cedet/ede/cpp-root.el" (0 0 0 0)) ;;; Generated autoloads from cedet/ede/cpp-root.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/cpp-root" '("ede-c"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "ede/cpp-root" '("ede-cpp-root-"))) ;;;*** @@ -9889,6 +9947,12 @@ It creates an autoload function for CNAME's constructor. ;;;*** +;;;### (autoloads nil "eldoc" "emacs-lisp/eldoc.el" (0 0 0 0)) +;;; Generated autoloads from emacs-lisp/eldoc.el +(push (purecopy '(eldoc 1 0 0)) package--builtin-versions) + +;;;*** + ;;;### (autoloads nil "elec-pair" "elec-pair.el" (0 0 0 0)) ;;; Generated autoloads from elec-pair.el @@ -12452,16 +12516,16 @@ operating on the next file and nil otherwise. (autoload 'fileloop-initialize-replace "fileloop" "\ Initialize a new round of query&replace on several files. - FROM is a regexp and TO is the replacement to use. - FILES describes the files, as in `fileloop-initialize'. - CASE-FOLD can be t, nil, or `default': - if it is nil, matching of FROM is case-sensitive. - if it is t, matching of FROM is case-insensitive, except - when `search-upper-case' is non-nil and FROM includes - upper-case letters. - if it is `default', the function uses the value of - `case-fold-search' instead. - DELIMITED if non-nil means replace only word-delimited matches. +FROM is a regexp and TO is the replacement to use. +FILES describes the files, as in `fileloop-initialize'. +CASE-FOLD can be t, nil, or `default': + if it is nil, matching of FROM is case-sensitive. + if it is t, matching of FROM is case-insensitive, except + when `search-upper-case' is non-nil and FROM includes + upper-case letters. + if it is `default', the function uses the value of + `case-fold-search' instead. +DELIMITED if non-nil means replace only word-delimited matches. \(fn FROM TO FILES CASE-FOLD &optional DELIMITED)" nil nil) @@ -12767,6 +12831,13 @@ Interactively, prompt for LIBRARY using the one at or near point. \(fn LIBRARY)" t nil) +(autoload 'read-library-name "find-func" "\ +Read and return a library name, defaulting to the one near point. + +A library name is the filename of an Emacs Lisp library located +in a directory under `load-path' (or `find-function-source-path', +if non-nil)." nil nil) + (autoload 'find-library-other-window "find-func" "\ Find the Emacs Lisp source of LIBRARY in another window. @@ -12934,7 +13005,7 @@ Find directly the variable at point in the other window." t nil) (autoload 'find-function-setup-keys "find-func" "\ Define some key bindings for the find-function family of functions." nil nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-" "read-library-name"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "find-func" '("find-"))) ;;;*** @@ -13373,7 +13444,54 @@ play around with the following keys: ;;;### (autoloads nil "format-spec" "format-spec.el" (0 0 0 0)) ;;; Generated autoloads from format-spec.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "format-spec" '("format-spec"))) +(autoload 'format-spec "format-spec" "\ +Return a string based on FORMAT and SPECIFICATION. +FORMAT is a string containing `format'-like specs like \"su - %u %k\". +SPECIFICATION is an alist mapping format specification characters +to their substitutions. + +For instance: + + (format-spec \"su - %u %l\" + \\=`((?u . ,(user-login-name)) + (?l . \"ls\"))) + +Each %-spec may contain optional flag, width, and precision +modifiers, as follows: + + %<flags><width><precision>character + +The following flags are allowed: + +* 0: Pad to the width, if given, with zeros instead of spaces. +* -: Pad to the width, if given, on the right instead of the left. +* <: Truncate to the width and precision, if given, on the left. +* >: Truncate to the width and precision, if given, on the right. +* ^: Convert to upper case. +* _: Convert to lower case. + +The width and truncation modifiers behave like the corresponding +ones in `format' when applied to %s. + +For example, \"%<010b\" means \"substitute into the output the +value associated with ?b in SPECIFICATION, either padding it with +leading zeros or truncating leading characters until it's ten +characters wide\". + +Any text properties of FORMAT are copied to the result, with any +text properties of a %-spec itself copied to its substitution. + +IGNORE-MISSING indicates how to handle %-spec characters not +present in SPECIFICATION. If it is nil or omitted, emit an +error; if it is the symbol `ignore', leave those %-specs verbatim +in the result, including their text properties, if any; if it is +the symbol `delete', remove those %-specs from the result; +otherwise do the same as for the symbol `ignore', but also leave +any occurrences of \"%%\" in FORMAT verbatim in the result. + +\(fn FORMAT SPECIFICATION &optional IGNORE-MISSING)" nil nil) + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "format-spec" '("format-spec-"))) ;;;*** @@ -13558,7 +13676,7 @@ and choose the directory as the fortune-file. Minimum set of parameters to filter for live (on-session) framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") -(defvar frameset-persistent-filter-alist (nconc '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\ +(defvar frameset-persistent-filter-alist (append '((background-color . frameset-filter-sanitize-color) (buffer-list . :never) (buffer-predicate . :never) (buried-buffer-list . :never) (client . :never) (delete-before . :never) (font . frameset-filter-font-param) (font-backend . :never) (foreground-color . frameset-filter-sanitize-color) (frameset--text-pixel-height . :save) (frameset--text-pixel-width . :save) (fullscreen . frameset-filter-shelve-param) (GUI:font . frameset-filter-unshelve-param) (GUI:fullscreen . frameset-filter-unshelve-param) (GUI:height . frameset-filter-unshelve-param) (GUI:width . frameset-filter-unshelve-param) (height . frameset-filter-shelve-param) (outer-window-id . :never) (parent-frame . :never) (parent-id . :never) (mouse-wheel-frame . :never) (tty . frameset-filter-tty-to-GUI) (tty-type . frameset-filter-tty-to-GUI) (width . frameset-filter-shelve-param) (window-id . :never) (window-system . :never)) frameset-session-filter-alist) "\ Parameters to filter for persistent framesets. DO NOT MODIFY. See `frameset-filter-alist' for a full description.") @@ -14267,6 +14385,10 @@ DELAY is a string, giving the length of the time. Possible values are: * hh:mm for a specific time. Use 24h format. If it is later than this time, then the deadline is tomorrow, else today. +The value of `message-draft-headers' determines which headers are +generated when the article is delayed. Remaining headers are +generated when the article is sent. + \(fn DELAY)" t nil) (autoload 'gnus-delay-send-queue "gnus-delay" "\ @@ -15373,9 +15495,13 @@ arguments as NAME. DO is a function as defined in `gv-get'. \(fn SYMBOL NAME ARGS HANDLER &optional FIX)" nil nil) -(or (assq 'gv-expander defun-declarations-alist) (let ((x `(gv-expander ,(apply-partially #'gv--defun-declaration 'gv-expander)))) (push x macro-declarations-alist) (push x defun-declarations-alist))) +(defsubst gv--expander-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-expander args)) -(or (assq 'gv-setter defun-declarations-alist) (push `(gv-setter ,(apply-partially #'gv--defun-declaration 'gv-setter)) defun-declarations-alist)) +(defsubst gv--setter-defun-declaration (&rest args) (apply #'gv--defun-declaration 'gv-setter args)) + +(or (assq 'gv-expander defun-declarations-alist) (let ((x (list 'gv-expander #'gv--expander-defun-declaration))) (push x macro-declarations-alist) (push x defun-declarations-alist))) + +(or (assq 'gv-setter defun-declarations-alist) (push (list 'gv-setter #'gv--setter-defun-declaration) defun-declarations-alist)) (autoload 'gv-define-setter "gv" "\ Define a setter method for generalized variable NAME. @@ -15737,6 +15863,28 @@ BUFFER should be a buffer or a buffer name. \(fn &optional BUFFER)" t nil) +(autoload 'describe-keymap "help-fns" "\ +Describe key bindings in KEYMAP. +When called interactively, prompt for a variable that has a +keymap value. + +\(fn KEYMAP)" t nil) + +(autoload 'describe-mode "help-fns" "\ +Display documentation of current major mode and minor modes. +A brief summary of the minor modes comes first, followed by the +major mode description. This is followed by detailed +descriptions of the minor modes, each on a separate page. + +For this to work correctly for a minor mode, the mode's indicator +variable (listed in `minor-mode-alist') must also be a function +whose documentation describes the minor mode. + +If called from Lisp with a non-nil BUFFER argument, display +documentation for the major and minor modes of that buffer. + +\(fn &optional BUFFER)" t nil) + (autoload 'doc-file-to-man "help-fns" "\ Produce an nroff buffer containing the doc-strings from the DOC file. @@ -15779,10 +15927,10 @@ Commands: \(fn)" t nil) (autoload 'help-mode-setup "help-mode" "\ -Enter Help Mode in the current buffer." nil nil) +Enter Help mode in the current buffer." nil nil) (autoload 'help-mode-finish "help-mode" "\ -Finalize Help Mode setup in current buffer." nil nil) +Finalize Help mode setup in current buffer." nil nil) (autoload 'help-setup-xref "help-mode" "\ Invoked from commands using the \"*Help*\" buffer to install some xref info. @@ -16094,6 +16242,9 @@ of text in those lines. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. @@ -16109,6 +16260,13 @@ Use the global history list for FACE. Limit face setting to the corresponding SUBEXP (interactively, the prefix argument) of REGEXP. If SUBEXP is omitted or nil, the entire REGEXP is highlighted. +LIGHTER is a human-readable string that can be used to select +a regexp to unhighlight by its name instead of selecting a possibly +complex regexp or closure. + +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the highlighting will not update as you type. The Font Lock mode @@ -16116,7 +16274,7 @@ is considered \"enabled\" in a buffer if its `major-mode' causes `font-lock-specified-p' to return non-nil, which means the major mode specifies support for Font Lock. -\(fn REGEXP &optional FACE SUBEXP)" t nil) +\(fn REGEXP &optional FACE SUBEXP LIGHTER)" t nil) (defalias 'highlight-phrase 'hi-lock-face-phrase-buffer) @@ -16125,9 +16283,9 @@ Set face of each match of phrase REGEXP to FACE. Interactively, prompt for REGEXP using `read-regexp', then FACE. Use the global history list for FACE. -When called interactively, replace whitespace in user-provided -regexp with arbitrary whitespace, and make initial lower-case -letters case-insensitive, before highlighting with `hi-lock-set-pattern'. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. +Also set `search-spaces-regexp' to the value of `search-whitespace-regexp'. Use Font lock mode, if enabled, to highlight REGEXP. Otherwise, use overlays for highlighting. If overlays are used, the @@ -16146,6 +16304,9 @@ Uses the next face from `hi-lock-face-defaults' without prompting, unless you use a prefix argument. Uses `find-tag-default-as-symbol-regexp' to retrieve the symbol at point. +If REGEXP contains upper case characters (excluding those preceded by `\\') +and `search-upper-case' is non-nil, the matching is case-sensitive. + This uses Font lock mode if it is enabled; otherwise it uses overlays, in which case the highlighting will not update as you type. The Font Lock mode is considered \"enabled\" in a buffer if its `major-mode' @@ -16425,7 +16586,6 @@ See `highlight-changes-mode' for more information on Highlight-Changes mode. ;;;### (autoloads nil "hippie-exp" "hippie-exp.el" (0 0 0 0)) ;;; Generated autoloads from hippie-exp.el -(push (purecopy '(hippie-exp 1 6)) package--builtin-versions) (defvar hippie-expand-try-functions-list '(try-complete-file-name-partially try-complete-file-name try-expand-all-abbrevs try-expand-list try-expand-line try-expand-dabbrev try-expand-dabbrev-all-buffers try-expand-dabbrev-from-kill try-complete-lisp-symbol-partially try-complete-lisp-symbol) "\ The list of expansion functions tried in order by `hippie-expand'. @@ -16847,7 +17007,6 @@ If optional arg OTHER-WINDOW is non-nil, then use another window. ;;;### (autoloads nil "icalendar" "calendar/icalendar.el" (0 0 0 ;;;;;; 0)) ;;; Generated autoloads from calendar/icalendar.el -(push (purecopy '(icalendar 0 19)) package--builtin-versions) (autoload 'icalendar-export-file "icalendar" "\ Export diary file to iCalendar format. @@ -17166,7 +17325,6 @@ The main features of this mode are 8. Hooks ----- - Loading idlwave.el runs `idlwave-load-hook'. Turning on `idlwave-mode' runs `idlwave-mode-hook'. 9. Documentation and Customization @@ -18276,6 +18434,7 @@ Moving within a node: already visible, try to go to the previous menu entry, or up if there is none. \\[beginning-of-buffer] Go to beginning of node. +\\[end-of-buffer] Go to end of node. Advanced commands: \\[Info-search] Search through this Info file for specified regexp, @@ -19051,7 +19210,7 @@ one of the aforementioned options instead of using this mode. ;;;### (autoloads nil "json" "json.el" (0 0 0 0)) ;;; Generated autoloads from json.el -(push (purecopy '(json 1 4)) package--builtin-versions) +(push (purecopy '(json 1 5)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "json" '("json-"))) @@ -19059,7 +19218,7 @@ one of the aforementioned options instead of using this mode. ;;;### (autoloads nil "jsonrpc" "jsonrpc.el" (0 0 0 0)) ;;; Generated autoloads from jsonrpc.el -(push (purecopy '(jsonrpc 1 0 9)) package--builtin-versions) +(push (purecopy '(jsonrpc 1 0 12)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "jsonrpc" '("jrpc-default-request-timeout" "jsonrpc-"))) @@ -19541,7 +19700,6 @@ generations (this defaults to 1). ;;;### (autoloads nil "linum" "linum.el" (0 0 0 0)) ;;; Generated autoloads from linum.el -(push (purecopy '(linum 0 9 24)) package--builtin-versions) (autoload 'linum-mode "linum" "\ Toggle display of line numbers in the left margin (Linum mode). @@ -19839,7 +19997,7 @@ This function is suitable for execution in an init file. \(fn &optional ARG)" t nil) -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "lunar-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "lunar" '("calendar-lunar-phases" "diary-lunar-phases" "eclipse-check" "lunar-"))) ;;;*** @@ -20421,10 +20579,6 @@ names or descriptions. The pattern argument is usually an -k pattern -Note that in some cases you will need to use \\[quoted-insert] to quote the -SPC character in the above examples, because this command attempts -to auto-complete your input based on the installed manual pages. - \(fn MAN-ARGS)" t nil) (autoload 'man-follow "man" "\ @@ -20443,7 +20597,7 @@ Default bookmark handler for Man buffers. ;;;### (autoloads nil "map" "emacs-lisp/map.el" (0 0 0 0)) ;;; Generated autoloads from emacs-lisp/map.el -(push (purecopy '(map 2 0)) package--builtin-versions) +(push (purecopy '(map 2 1)) package--builtin-versions) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "map" '("map-"))) @@ -20451,7 +20605,6 @@ Default bookmark handler for Man buffers. ;;;### (autoloads nil "master" "master.el" (0 0 0 0)) ;;; Generated autoloads from master.el -(push (purecopy '(master 1 0 2)) package--builtin-versions) (autoload 'master-mode "master" "\ Toggle Master mode. @@ -20661,49 +20814,6 @@ Major mode for editing MetaPost sources. ;;;*** -;;;### (autoloads nil "metamail" "mail/metamail.el" (0 0 0 0)) -;;; Generated autoloads from mail/metamail.el - -(autoload 'metamail-interpret-header "metamail" "\ -Interpret a header part of a MIME message in current buffer. -Its body part is not interpreted at all." t nil) - -(autoload 'metamail-interpret-body "metamail" "\ -Interpret a body part of a MIME message in current buffer. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. -Its header part is not interpreted at all. - -\(fn &optional VIEWMODE NODISPLAY)" t nil) - -(autoload 'metamail-buffer "metamail" "\ -Process current buffer through `metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. - -\(fn &optional VIEWMODE BUFFER NODISPLAY)" t nil) - -(autoload 'metamail-region "metamail" "\ -Process current region through `metamail'. -Optional argument VIEWMODE specifies the value of the -EMACS_VIEW_MODE environment variable (defaulted to 1). -Optional argument BUFFER specifies a buffer to be filled (nil -means current). -Optional argument NODISPLAY non-nil means buffer is not -redisplayed as output is inserted. - -\(fn BEG END &optional VIEWMODE BUFFER NODISPLAY)" t nil) - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "metamail" '("metamail-"))) - -;;;*** - ;;;### (autoloads nil "mh-acros" "mh-e/mh-acros.el" (0 0 0 0)) ;;; Generated autoloads from mh-e/mh-acros.el @@ -22174,6 +22284,10 @@ values: `ssl' -- Equivalent to `tls'. `shell' -- A shell connection. +:coding is a symbol or a cons used to specify the coding systems +used to decode and encode the data which the process reads and +writes. See `make-network-process' for details. + :return-list specifies this function's return value. If omitted or nil, return a process object. A non-nil means to return (PROC . PROPS), where PROC is a process object and PROPS @@ -22227,8 +22341,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -24750,8 +24864,9 @@ matching parenthesis is highlighted in `show-paren-style' after (autoload 'parse-time-string "parse-time" "\ Parse the time in STRING into (SEC MIN HOUR DAY MON YEAR DOW DST TZ). -STRING should be something resembling an RFC 822 (or later) date-time, e.g., -\"Fri, 25 Mar 2016 16:24:56 +0100\", but this function is +STRING should be an ISO 8601 time string, e.g., \"2020-01-15T16:12:21-08:00\", +or something resembling an RFC 822 (or later) date-time, e.g., +\"Wed, 15 Jan 2020 16:12:21 -0800\". This function is somewhat liberal in what format it accepts, and will attempt to return a \"likely\" value even for somewhat malformed strings. The values returned are identical to those of `decode-time', but @@ -26136,16 +26251,19 @@ Open profile FILENAME. ;;;### (autoloads nil "project" "progmodes/project.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/project.el +(push (purecopy '(project 0 4 0)) package--builtin-versions) (autoload 'project-current "project" "\ Return the project instance in DIR or `default-directory'. When no project found in DIR, and MAYBE-PROMPT is non-nil, ask -the user for a different directory to look in. If that directory -is not a part of a detectable project either, return a -`transient' project instance rooted in it. +the user for a different project to look in. \(fn &optional MAYBE-PROMPT DIR)" nil nil) +(defvar project-prefix-map (let ((map (make-sparse-keymap))) (define-key map "f" 'project-find-file) (define-key map "b" 'project-switch-to-buffer) (define-key map "s" 'project-shell) (define-key map "d" 'project-dired) (define-key map "v" 'project-vc-dir) (define-key map "c" 'project-compile) (define-key map "e" 'project-eshell) (define-key map "k" 'project-kill-buffers) (define-key map "p" 'project-switch-project) (define-key map "g" 'project-find-regexp) (define-key map "r" 'project-query-replace-regexp) map) "\ +Keymap for project commands.") + (define-key ctl-x-map "p" project-prefix-map) + (autoload 'project-find-regexp "project" "\ Find all matches for REGEXP in the current project's roots. With \\[universal-argument] prefix, you can specify the directory @@ -26165,15 +26283,35 @@ pattern to search for. \(fn REGEXP)" t nil) (autoload 'project-find-file "project" "\ -Visit a file (with completion) in the current project's roots. +Visit a file (with completion) in the current project. The completion default is the filename at point, if one is recognized." t nil) (autoload 'project-or-external-find-file "project" "\ -Visit a file (with completion) in the current project's roots or external roots. +Visit a file (with completion) in the current project or external roots. The completion default is the filename at point, if one is recognized." t nil) +(autoload 'project-dired "project" "\ +Start Dired in the current project's root." t nil) + +(autoload 'project-vc-dir "project" "\ +Run VC-Dir in the current project's root." t nil) + +(autoload 'project-shell "project" "\ +Start an inferior shell in the current project's root directory. +If a buffer already exists for running a shell in the project's root, +switch to it. Otherwise, create a new shell buffer. +With \\[universal-argument] prefix arg, create a new inferior shell buffer even +if one already exists." t nil) + +(autoload 'project-eshell "project" "\ +Start Eshell in the current project's root directory. +If a buffer already exists for running Eshell in the project's root, +switch to it. Otherwise, create a new Eshell buffer. +With \\[universal-argument] prefix arg, create a new Eshell buffer even +if one already exists." t nil) + (autoload 'project-search "project" "\ Search for REGEXP in all the files of the project. Stops when a match is found. @@ -26190,6 +26328,38 @@ loop using the command \\[fileloop-continue]. \(fn FROM TO)" t nil) +(autoload 'project-compile "project" "\ +Run `compile' in the project root. +Arguments the same as in `compile'. + +\(fn COMMAND &optional COMINT)" t nil) + +(autoload 'project-switch-to-buffer "project" "\ +Switch to another buffer that is related to the current project. +A buffer is related to a project if its `default-directory' +is inside the directory hierarchy of the project's root." t nil) + +(autoload 'project-kill-buffers "project" "\ +Kill all live buffers belonging to the current project. +Certain buffers may be \"spared\", see `project-kill-buffers-ignores'." t nil) + +(autoload 'project-known-project-roots "project" "\ +Return the list of root directories of all known projects." nil nil) + +(defvar project-switch-commands '((102 "Find file" project-find-file) (103 "Find regexp" project-find-regexp) (100 "Dired" project-dired) (118 "VC-Dir" project-vc-dir) (101 "Eshell" project-eshell)) "\ +Alist mapping keys to project switching menu entries. +Used by `project-switch-project' to construct a dispatch menu of +commands available upon \"switching\" to another project. + +Each element is of the form (KEY LABEL COMMAND), where COMMAND is the +command to run when KEY is pressed. LABEL is used to distinguish +the menu entries in the dispatch menu.") + +(autoload 'project-switch-project "project" "\ +\"Switch\" to another project by running an Emacs command. +The available commands are presented as a dispatch menu +made from `project-switch-commands'." t nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "project" '("project-"))) ;;;*** @@ -26845,7 +27015,7 @@ HELP-TEXT is a text set in `hangul-input-method-help-text'. ;;;;;; 0 0)) ;;; Generated autoloads from leim/quail/indian.el -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/indian" '("inscript-" "quail-"))) +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "quail/indian" '("indian-mlm-mozhi-u" "inscript-" "quail-"))) ;;;*** @@ -27504,7 +27674,6 @@ This means the number of non-shy regexp grouping constructs ;;;### (autoloads nil "remember" "textmodes/remember.el" (0 0 0 0)) ;;; Generated autoloads from textmodes/remember.el -(push (purecopy '(remember 2 0)) package--builtin-versions) (autoload 'remember "remember" "\ Remember an arbitrary piece of data. @@ -27556,7 +27725,6 @@ to turn the *scratch* buffer into your notes buffer. ;;;### (autoloads nil "repeat" "repeat.el" (0 0 0 0)) ;;; Generated autoloads from repeat.el -(push (purecopy '(repeat 0 51)) package--builtin-versions) (autoload 'repeat "repeat" "\ Repeat most recently executed command. @@ -28431,7 +28599,6 @@ Major mode for editing Ruby code. ;;;### (autoloads nil "ruler-mode" "ruler-mode.el" (0 0 0 0)) ;;; Generated autoloads from ruler-mode.el -(push (purecopy '(ruler-mode 1 6)) package--builtin-versions) (defvar ruler-mode nil "\ Non-nil if Ruler mode is enabled. @@ -28639,7 +28806,7 @@ For more details, see Info node `(elisp) Extending Rx'. \(fn NAME [(ARGS...)] RX)" nil t) -(function-put 'rx-define 'lisp-indent-function '1) +(function-put 'rx-define 'lisp-indent-function 'defun) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "rx" '("rx-"))) @@ -28682,6 +28849,14 @@ For more details, see Info node `(elisp) Extending Rx'. ;;;*** +;;;### (autoloads nil "sasl-scram-sha256" "net/sasl-scram-sha256.el" +;;;;;; (0 0 0 0)) +;;; Generated autoloads from net/sasl-scram-sha256.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sasl-scram-sha256" '("sasl-scram-sha"))) + +;;;*** + ;;;### (autoloads nil "savehist" "savehist.el" (0 0 0 0)) ;;; Generated autoloads from savehist.el (push (purecopy '(savehist 24)) package--builtin-versions) @@ -28783,13 +28958,6 @@ file: ;;;*** -;;;### (autoloads nil "sb-image" "sb-image.el" (0 0 0 0)) -;;; Generated autoloads from sb-image.el - -(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "sb-image" '("defimage-speedbar" "speedbar-"))) - -;;;*** - ;;;### (autoloads nil "scheme" "progmodes/scheme.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/scheme.el @@ -29905,6 +30073,11 @@ If SEQUENCE is empty, return INITIAL-VALUE and FUNCTION is not called. \(fn FUNCTION SEQUENCE INITIAL-VALUE)" nil nil) +(autoload 'seq-every-p "seq" "\ +Return non-nil if (PRED element) is non-nil for all elements of SEQUENCE. + +\(fn PRED SEQUENCE)" nil nil) + (autoload 'seq-some "seq" "\ Return non-nil if PRED is satisfied for at least one element of SEQUENCE. If so, return the first non-nil value returned by PRED. @@ -30095,7 +30268,7 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6> <p>Paragraphs only need an opening tag. Line breaks and multiple spaces are ignored unless the text is <pre>preformatted.</pre> Text can be marked as -<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or +<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o or Edit/Text Properties/Face commands. Pages can have <a name=\"SOMENAME\">named points</a> and can link other points @@ -30153,11 +30326,9 @@ following commands are available, based on the current shell's syntax: \\[sh-while] while loop For sh and rc shells indentation commands are: -\\[sh-show-indent] Show the variable controlling this line's indentation. -\\[sh-set-indent] Set then variable controlling this line's indentation. -\\[sh-learn-line-indent] Change the indentation variable so this line -would indent to the way it currently is. -\\[sh-learn-buffer-indent] Set the indentation variables so the +\\[smie-config-show-indent] Show the rules controlling this line's indentation. +\\[smie-config-set-indent] Change the rules controlling this line's indentation. +\\[smie-config-guess] Try to tweak the indentation rules so the buffer indents as it currently is indented. @@ -30614,7 +30785,9 @@ enable the mode if ARG is omitted or nil, and toggle it if ARG is (autoload 'smerge-start-session "smerge-mode" "\ Turn on `smerge-mode' and move point to first conflict marker. -If no conflict maker is found, turn off `smerge-mode'." t nil) +If no conflict maker is found, turn off `smerge-mode'. + +\(fn &optional INTERACTIVELY)" t nil) (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "smerge-mode" '("smerge-"))) @@ -32078,6 +32251,11 @@ The variable list SPEC is the same as in `if-let'. (function-put 'when-let 'lisp-indent-function '1) +(autoload 'string-truncate-left "subr-x" "\ +Truncate STRING to LENGTH, replacing initial surplus with \"...\". + +\(fn STRING LENGTH)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "subr-x" '("and-let*" "hash-table-" "if-let" "internal--" "replace-region-contents" "string-" "thread-" "when-let*"))) ;;;*** @@ -33270,7 +33448,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on.") (custom-autoload 'tex-show-queue-command "tex-mode" t) -(defvar tex-default-mode 'latex-mode "\ +(defvar tex-default-mode #'latex-mode "\ Mode to enter for a new file that might be either TeX or LaTeX. This variable is used when it can't be determined whether the file is plain TeX or LaTeX or what because the file contains no commands. @@ -33290,11 +33468,14 @@ String inserted by typing \\[tex-insert-quote] to close a quotation.") (autoload 'tex-mode "tex-mode" "\ Major mode for editing files of input for TeX, LaTeX, or SliTeX. +This is the shared parent mode of several submodes. Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', -`latex-mode', or `slitex-mode', respectively. If it cannot be determined, +`latex-mode', or `slitex-mode', accordingly. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' -says which mode to use." t nil) +says which mode to use. + +\(fn)" t nil) (defalias 'TeX-mode 'tex-mode) @@ -34505,7 +34686,7 @@ the output buffer or changing the window configuration. ;;;### (autoloads nil "tramp" "net/tramp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp.el -(push (purecopy '(tramp 2 4 3)) package--builtin-versions) +(push (purecopy '(tramp 2 5 0 -1)) package--builtin-versions) (defvar tramp-mode t "\ Whether Tramp is enabled. @@ -34535,18 +34716,15 @@ match file names at root of the underlying local file system, like \"/sys\" or \"/C:\".") (defun tramp-autoload-file-name-handler (operation &rest args) "\ -Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (if tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) +Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) (when tramp-mode (let ((default-directory temporary-file-directory)) (load "tramp" 'noerror 'nomessage))) (apply operation args)) (defun tramp-register-autoload-file-name-handlers nil "\ -Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put 'tramp-autoload-file-name-handler 'safe-magic t)) +Add Tramp file name handlers to `file-name-handler-alist' during autoload." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) (put #'tramp-autoload-file-name-handler 'safe-magic t)) (tramp-register-autoload-file-name-handlers) (defun tramp-unload-file-name-handlers nil "\ Unload Tramp file name handlers from `file-name-handler-alist'." (dolist (fnh file-name-handler-alist) (when (and (symbolp (cdr fnh)) (string-prefix-p "tramp-" (symbol-name (cdr fnh)))) (setq file-name-handler-alist (delq fnh file-name-handler-alist))))) -(defvar tramp-completion-mode nil "\ -If non-nil, external packages signal that they are in file name completion.") - (defun tramp-unload-tramp nil "\ Discard Tramp from loading remote files." (interactive) (ignore-errors (unload-feature 'tramp 'force))) @@ -34582,7 +34760,7 @@ Regular expression matching archive file names." '(concat "\\`" "\\(" ".+" "\\." (defalias 'tramp-archive-autoload-file-name-handler #'tramp-autoload-file-name-handler) (defun tramp-register-archive-file-name-handler nil "\ -Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put 'tramp-archive-autoload-file-name-handler 'safe-magic t))) +Add archive file name handler to `file-name-handler-alist'." (when tramp-archive-enabled (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) (put #'tramp-archive-autoload-file-name-handler 'safe-magic t))) (add-hook 'after-init-hook #'tramp-register-archive-file-name-handler) @@ -34614,6 +34792,13 @@ Add archive file name handler to `file-name-handler-alist'." (when tramp-archive ;;;*** +;;;### (autoloads nil "tramp-crypt" "net/tramp-crypt.el" (0 0 0 0)) +;;; Generated autoloads from net/tramp-crypt.el + +(if (fboundp 'register-definition-prefixes) (register-definition-prefixes "tramp-crypt" '("tramp-crypt-"))) + +;;;*** + ;;;### (autoloads nil "tramp-ftp" "net/tramp-ftp.el" (0 0 0 0)) ;;; Generated autoloads from net/tramp-ftp.el @@ -35933,7 +36118,10 @@ Note that if FILE is a symbolic link, it will not be resolved -- the responsible backend system for the symbolic link itself will be reported. -\(fn FILE)" nil nil) +If NO-ERROR is nil, signal an error that no VC backend is +responsible for the given file. + +\(fn FILE &optional NO-ERROR)" nil nil) (autoload 'vc-next-action "vc" "\ Do the next logical version control operation on the current fileset. @@ -36129,7 +36317,7 @@ with its diffs (if the underlying VCS supports that). \(fn &optional LIMIT REVISION)" t nil) (autoload 'vc-print-branch-log "vc" "\ -Show the change log for BRANCH in a window. +Show the change log for BRANCH root in a window. \(fn BRANCH)" t nil) @@ -36353,6 +36541,11 @@ Name of the format file in a .bzr directory.") ;;;### (autoloads nil "vc-dir" "vc/vc-dir.el" (0 0 0 0)) ;;; Generated autoloads from vc/vc-dir.el +(autoload 'vc-dir-root "vc-dir" "\ +Run `vc-dir' in the repository root directory without prompt. +If the default directory of the current buffer is +not under version control, prompt for a directory." t nil) + (autoload 'vc-dir "vc-dir" "\ Show the VC status for \"interesting\" files in and below DIR. This allows you to mark files and perform VC operations on them. @@ -36372,6 +36565,13 @@ These are the commands available for use in the file status buffer: \(fn DIR &optional BACKEND)" t nil) +(autoload 'vc-dir-bookmark-jump "vc-dir" "\ +Provides the bookmark-jump behavior for a `vc-dir' buffer. +This implements the `handler' function interface for the record +type returned by `vc-dir-bookmark-make-record'. + +\(fn BMK)" nil nil) + (if (fboundp 'register-definition-prefixes) (register-definition-prefixes "vc-dir" '("vc-"))) ;;;*** @@ -36589,7 +36789,7 @@ Key bindings: ;;;### (autoloads nil "verilog-mode" "progmodes/verilog-mode.el" ;;;;;; (0 0 0 0)) ;;; Generated autoloads from progmodes/verilog-mode.el -(push (purecopy '(verilog-mode 2019 12 17 268053413)) package--builtin-versions) +(push (purecopy '(verilog-mode 2020 2 23 232634261)) package--builtin-versions) (autoload 'verilog-mode "verilog-mode" "\ Major mode for editing Verilog code. @@ -37781,7 +37981,6 @@ this is equivalent to `display-warning', using ;;;### (autoloads nil "wdired" "wdired.el" (0 0 0 0)) ;;; Generated autoloads from wdired.el -(push (purecopy '(wdired 2 0)) package--builtin-versions) (autoload 'wdired-change-to-wdired-mode "wdired" "\ Put a Dired buffer in Writable Dired (WDired) mode. @@ -38380,6 +38579,11 @@ Display the next buffer in the same window. \(fn &optional ARG)" t nil) +(autoload 'windmove-display-new-frame "windmove" "\ +Display the next buffer in a new frame. + +\(fn &optional ARG)" t nil) + (autoload 'windmove-display-new-tab "windmove" "\ Display the next buffer in a new tab. @@ -38492,7 +38696,6 @@ you can press `C-c <right>' (calling `winner-redo'). ;;;### (autoloads nil "woman" "woman.el" (0 0 0 0)) ;;; Generated autoloads from woman.el -(push (purecopy '(woman 0 551)) package--builtin-versions) (defvar woman-locale nil "\ String specifying a manual page locale, or nil. @@ -38639,6 +38842,7 @@ If LIMIT is non-nil, then do not consider characters beyond LIMIT. ;;;### (autoloads nil "xref" "progmodes/xref.el" (0 0 0 0)) ;;; Generated autoloads from progmodes/xref.el +(push (purecopy '(xref 1 0 1)) package--builtin-versions) (autoload 'xref-find-backend "xref" nil nil nil) @@ -38864,31 +39068,40 @@ Zone out, completely." t nil) ;;;;;; "electric.el" "emacs-lisp/backquote.el" "emacs-lisp/byte-run.el" ;;;;;; "emacs-lisp/cl-extra.el" "emacs-lisp/cl-macs.el" "emacs-lisp/cl-preloaded.el" ;;;;;; "emacs-lisp/cl-seq.el" "emacs-lisp/eieio-compat.el" "emacs-lisp/eieio-custom.el" -;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/eldoc.el" "emacs-lisp/float-sup.el" -;;;;;; "emacs-lisp/lisp-mode.el" "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" -;;;;;; "emacs-lisp/map-ynp.el" "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el" -;;;;;; "emacs-lisp/timer.el" "env.el" "epa-hook.el" "erc/erc-autoaway.el" -;;;;;; "erc/erc-button.el" "erc/erc-capab.el" "erc/erc-compat.el" -;;;;;; "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" "erc/erc-ezbounce.el" -;;;;;; "erc/erc-fill.el" "erc/erc-identd.el" "erc/erc-imenu.el" -;;;;;; "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" "erc/erc-match.el" -;;;;;; "erc/erc-menu.el" "erc/erc-netsplit.el" "erc/erc-notify.el" -;;;;;; "erc/erc-page.el" "erc/erc-pcomplete.el" "erc/erc-replace.el" -;;;;;; "erc/erc-ring.el" "erc/erc-services.el" "erc/erc-sound.el" -;;;;;; "erc/erc-speedbar.el" "erc/erc-spelling.el" "erc/erc-stamp.el" -;;;;;; "erc/erc-track.el" "erc/erc-truncate.el" "erc/erc-xdcc.el" -;;;;;; "eshell/em-alias.el" "eshell/em-banner.el" "eshell/em-basic.el" -;;;;;; "eshell/em-cmpl.el" "eshell/em-dirs.el" "eshell/em-glob.el" -;;;;;; "eshell/em-hist.el" "eshell/em-ls.el" "eshell/em-pred.el" -;;;;;; "eshell/em-prompt.el" "eshell/em-rebind.el" "eshell/em-script.el" -;;;;;; "eshell/em-smart.el" "eshell/em-term.el" "eshell/em-tramp.el" -;;;;;; "eshell/em-unix.el" "eshell/em-xtra.el" "facemenu.el" "faces.el" -;;;;;; "files.el" "font-core.el" "font-lock.el" "format.el" "frame.el" -;;;;;; "help.el" "hfy-cmap.el" "ibuf-ext.el" "indent.el" "international/characters.el" +;;;;;; "emacs-lisp/eieio-opt.el" "emacs-lisp/float-sup.el" "emacs-lisp/lisp-mode.el" +;;;;;; "emacs-lisp/lisp.el" "emacs-lisp/macroexp.el" "emacs-lisp/map-ynp.el" +;;;;;; "emacs-lisp/nadvice.el" "emacs-lisp/syntax.el" "emacs-lisp/timer.el" +;;;;;; "env.el" "epa-hook.el" "erc/erc-autoaway.el" "erc/erc-button.el" +;;;;;; "erc/erc-capab.el" "erc/erc-compat.el" "erc/erc-dcc.el" "erc/erc-desktop-notifications.el" +;;;;;; "erc/erc-ezbounce.el" "erc/erc-fill.el" "erc/erc-identd.el" +;;;;;; "erc/erc-imenu.el" "erc/erc-join.el" "erc/erc-list.el" "erc/erc-log.el" +;;;;;; "erc/erc-match.el" "erc/erc-menu.el" "erc/erc-netsplit.el" +;;;;;; "erc/erc-notify.el" "erc/erc-page.el" "erc/erc-pcomplete.el" +;;;;;; "erc/erc-replace.el" "erc/erc-ring.el" "erc/erc-services.el" +;;;;;; "erc/erc-sound.el" "erc/erc-speedbar.el" "erc/erc-spelling.el" +;;;;;; "erc/erc-stamp.el" "erc/erc-track.el" "erc/erc-truncate.el" +;;;;;; "erc/erc-xdcc.el" "eshell/em-alias.el" "eshell/em-banner.el" +;;;;;; "eshell/em-basic.el" "eshell/em-cmpl.el" "eshell/em-dirs.el" +;;;;;; "eshell/em-glob.el" "eshell/em-hist.el" "eshell/em-ls.el" +;;;;;; "eshell/em-pred.el" "eshell/em-prompt.el" "eshell/em-rebind.el" +;;;;;; "eshell/em-script.el" "eshell/em-smart.el" "eshell/em-term.el" +;;;;;; "eshell/em-tramp.el" "eshell/em-unix.el" "eshell/em-xtra.el" +;;;;;; "facemenu.el" "faces.el" "files.el" "font-core.el" "font-lock.el" +;;;;;; "format.el" "frame.el" "help.el" "hfy-cmap.el" "ibuf-ext.el" +;;;;;; "indent.el" "international/characters.el" "international/charprop.el" ;;;;;; "international/charscript.el" "international/cp51932.el" ;;;;;; "international/eucjp-ms.el" "international/mule-cmds.el" -;;;;;; "international/mule-conf.el" "international/mule.el" "isearch.el" -;;;;;; "jit-lock.el" "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" +;;;;;; "international/mule-conf.el" "international/mule.el" "international/uni-bidi.el" +;;;;;; "international/uni-brackets.el" "international/uni-category.el" +;;;;;; "international/uni-combining.el" "international/uni-comment.el" +;;;;;; "international/uni-decimal.el" "international/uni-decomposition.el" +;;;;;; "international/uni-digit.el" "international/uni-lowercase.el" +;;;;;; "international/uni-mirrored.el" "international/uni-name.el" +;;;;;; "international/uni-numeric.el" "international/uni-old-name.el" +;;;;;; "international/uni-special-lowercase.el" "international/uni-special-titlecase.el" +;;;;;; "international/uni-special-uppercase.el" "international/uni-titlecase.el" +;;;;;; "international/uni-uppercase.el" "isearch.el" "jit-lock.el" +;;;;;; "jka-cmpr-hook.el" "language/burmese.el" "language/cham.el" ;;;;;; "language/chinese.el" "language/cyrillic.el" "language/czech.el" ;;;;;; "language/english.el" "language/ethiopic.el" "language/european.el" ;;;;;; "language/georgian.el" "language/greek.el" "language/hebrew.el" diff --git a/lisp/leim/quail/indian.el b/lisp/leim/quail/indian.el index 2681eab0e5e..100ae63f6ac 100644 --- a/lisp/leim/quail/indian.el +++ b/lisp/leim/quail/indian.el @@ -117,6 +117,7 @@ indian-knd-itrans-v5-hash "kannada-itrans" "Kannada" "KndIT" "Kannada transliteration by ITRANS method.") +;; ITRANS not applicable to Malayalam & could be removed eventually (if nil (quail-define-package "malayalam-itrans" "Malayalam" "MlmIT" t "Malayalam ITRANS")) (quail-define-indian-trans-package @@ -358,24 +359,23 @@ Full key sequences are listed below:") '( (;; VOWELS (18) (?D nil) (?E ?e) (?F ?f) (?R ?r) (?G ?g) (?T ?t) - (?+ ?=) ("F]" "f]") (?! ?@) (?S ?s) (?Z ?z) (?W ?w) - (?| ?\\) (?~ ?`) (?A ?a) (?Q ?q) ("+]" "=]") ("R]" "r]")) + (?= ?+) nil nil (?S ?s) (?Z ?z) (?W ?w) + nil (?~ ?`) (?A ?a) (?Q ?q)) (;; CONSONANTS (42) ?k ?K ?i ?I ?U ;; GRUTTALS ?\; ?: ?p ?P ?} ;; PALATALS ?' ?\" ?\[ ?{ ?C ;; CEREBRALS - ?l ?L ?o ?O ?v ?V ;; DENTALS + ?l ?L ?o ?O ?v nil ;; DENTALS ?h ?H ?y ?Y ?c ;; LABIALS - ?/ ?j ?J ?n ?N "N]" ?b ;; SEMIVOWELS + ?/ ?j ?J ?n ?N ?B ?b ;; SEMIVOWELS ?M ?< ?m ?u ;; SIBILANTS - "k]" "K]" "i]" "p]" "[]" "{]" "H]" "/]" ;; NUKTAS - ?% ?&) + nil nil nil nil nil nil nil nil nil) ;; NUKTAS (;; Misc Symbols (7) - ?X ?x ?_ ">]" ?d "X]" ?>) + nil ?x ?_ nil ?d) (;; Digits ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9) - (;; Inscripts - ?# ?$ ?^ ?* ?\]))) + (;; Chillus + "Cd" "Cd]" "vd" "vd]" "jd" "jd]" "nd" "nd]" "Nd" "Nd]"))) (defvar inscript-tml-keytable '( @@ -463,6 +463,9 @@ Full key sequences are listed below:") "malayalam-inscript" "Malayalam" "MlmIS" "Malayalam keyboard Inscript.") +(quail-defrule "\\" ?) +(quail-defrule "X" ?) + (if nil (quail-define-package "tamil-inscript" "Tamil" "TmlIS" t "Tamil keyboard Inscript")) (quail-define-inscript-package @@ -571,4 +574,72 @@ Full key sequences are listed below:") ("?" ?\?) ("/" ?্)) +(defun indian-mlm-mozhi-update-translation (control-flag) + (let ((len (length quail-current-key)) chillu + (vowels '(?a ?e ?i ?o ?u ?A ?E ?I ?O ?U ?R))) + (cond ((numberp control-flag) + (progn (if (= control-flag 0) + (setq quail-current-str quail-current-key) + (cond (input-method-exit-on-first-char) + ((and (memq (aref quail-current-key + (1- control-flag)) + vowels) + (setq chillu (cl-position + (aref quail-current-key + control-flag) + '(?m ?N ?n ?r ?l ?L)))) + ;; conditions for putting chillu + (and (or (and (= control-flag (1- len)) + (not (setq control-flag nil))) + (and (= control-flag (- len 2)) + (let ((temp (aref quail-current-key + (1- len)))) + ;; is it last char of word? + (not + (or (and (>= temp ?a) (<= temp ?z)) + (and (>= temp ?A) (<= temp ?Z)) + (eq temp ?~)))) + (setq control-flag (1+ control-flag)))) + (setq quail-current-str ;; put chillu + (concat (if (not (stringp + quail-current-str)) + (string quail-current-str) + quail-current-str) + (string + (nth chillu '(?ം ?ൺ ?ൻ ?ർ ?ൽ ?ൾ))))))))) + (and (not input-method-exit-on-first-char) control-flag + (while (> len control-flag) + (setq len (1- len)) + (setq unread-command-events + (cons (aref quail-current-key len) + unread-command-events)))) + )) + ((null control-flag) + (unless quail-current-str + (setq quail-current-str quail-current-key) + )) + ((equal control-flag t) + (if (memq (aref quail-current-key (1- len)) ;; If vowel ending, + vowels) ;; may have to put + (setq control-flag nil))))) ;; chillu. So don't + control-flag) ;; end translation + +(quail-define-package "malayalam-mozhi" "Malayalam" "MlmMI" t + "Malayalam transliteration by Mozhi method." + nil nil t nil nil nil t nil + 'indian-mlm-mozhi-update-translation) + +(maphash + (lambda (key val) + (quail-defrule key (if (= (length val) 1) + (string-to-char val) + (vector val)))) + (cdr indian-mlm-mozhi-hash)) + +(defun indian-mlm-mozhi-underscore (key len) (throw 'quail-tag nil)) + +(quail-defrule "_" 'indian-mlm-mozhi-underscore) +(quail-defrule "|" ?) +(quail-defrule "||" ?) + ;;; indian.el ends here diff --git a/lisp/leim/quail/latin-ltx.el b/lisp/leim/quail/latin-ltx.el index 35a9adbe29b..78ffca9e2fa 100644 --- a/lisp/leim/quail/latin-ltx.el +++ b/lisp/leim/quail/latin-ltx.el @@ -727,7 +727,9 @@ system, including many technical ones. Examples: ("\\ldq" ?\“) ("\\rdq" ?\”) ("\\defs" ?≙) ; per fuzz/zed - ;; ("\\sqrt[3]" ?∛) + ("\\sqrt" ?√) + ("\\sqrt[3]" ?∛) + ("\\sqrt[4]" ?∜) ("\\llbracket" ?\〚) ; stmaryrd ("\\rrbracket" ?\〛) ;; ("\\lbag" ?\〚) ; fuzz diff --git a/lisp/linum.el b/lisp/linum.el index 8f0e7ddce4d..e8c364245ae 100644 --- a/lisp/linum.el +++ b/lisp/linum.el @@ -5,7 +5,7 @@ ;; Author: Markus Triska <markus.triska@gmx.at> ;; Maintainer: emacs-devel@gnu.org ;; Keywords: convenience -;; Version: 0.9x +;; Old-Version: 0.9x ;; This file is part of GNU Emacs. @@ -32,6 +32,7 @@ ;;; Code: (defconst linum-version "0.9x") +(make-obsolete-variable 'linum-version nil "28.1") (defvar linum-overlays nil "Overlays used in this buffer.") (defvar linum-available nil "Overlays available for reuse.") diff --git a/lisp/ls-lisp.el b/lisp/ls-lisp.el index 2952242c251..8851522bbdb 100644 --- a/lisp/ls-lisp.el +++ b/lisp/ls-lisp.el @@ -435,9 +435,9 @@ not contain `d', so that a full listing is expected." ;; text. But if the listing is empty, as e.g. in empty ;; directories with -a removed from switches, point will be ;; before the inserted text, and dired-insert-directory will - ;; not indent the listing correctly. Going to the end of the - ;; buffer fixes that. - (unless files (goto-char (point-max))) + ;; not indent the listing correctly. Getting past the + ;; inserted text solves this. + (unless (cdr total-line) (forward-line 2)) (if (memq ?R switches) ;; List the contents of all directories recursively. ;; cadr of each element of `file-alist' is t for diff --git a/lisp/mail/emacsbug.el b/lisp/mail/emacsbug.el index 7f3dc4454ab..efbc0668553 100644 --- a/lisp/mail/emacsbug.el +++ b/lisp/mail/emacsbug.el @@ -208,7 +208,11 @@ This requires either the macOS \"open\" command, or the freedesktop ;;;###autoload (defun report-emacs-bug (topic &optional unused) "Report a bug in GNU Emacs. -Prompts for bug subject. Leaves you in a mail buffer." +Prompts for bug subject. Leaves you in a mail buffer. + +Already submitted bugs can be found in the Emacs bug tracker: + + https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1" (declare (advertised-calling-convention (topic) "24.5")) (interactive "sBug Subject: ") ;; The syntax `version;' is preferred to `[version]' because the @@ -270,7 +274,7 @@ Prompts for bug subject. Leaves you in a mail buffer." 'face 'link 'help-echo (concat "mouse-2, RET: Follow this link") 'action (lambda (button) - (browse-url "https://debbugs.gnu.org/")) + (browse-url "https://debbugs.gnu.org/cgi/pkgreport.cgi?package=emacs;max-bugs=100;base-order=1;bug-rev=1")) 'follow-link t) (insert ". Please check that diff --git a/lisp/mail/feedmail.el b/lisp/mail/feedmail.el index b9920023d82..0d7193c1be0 100644 --- a/lisp/mail/feedmail.el +++ b/lisp/mail/feedmail.el @@ -1203,7 +1203,7 @@ no longer matches to transformed string. Used by function feedmail-tidy-up-slug and indirectly by feedmail-queue-subject-slug-maker." :version "24.1" :group 'feedmail-queue - :type 'string + :type 'regexp ) diff --git a/lisp/mail/qp.el b/lisp/mail/qp.el index 388c3981c97..35ff47fd098 100644 --- a/lisp/mail/qp.el +++ b/lisp/mail/qp.el @@ -1,4 +1,4 @@ -;;; qp.el --- Quoted-Printable functions +;;; qp.el --- Quoted-Printable functions -*- lexical-binding:t -*- ;; Copyright (C) 1998-2020 Free Software Foundation, Inc. diff --git a/lisp/mail/rfc2045.el b/lisp/mail/rfc2045.el index 7d962ea2348..dba9c04cc83 100644 --- a/lisp/mail/rfc2045.el +++ b/lisp/mail/rfc2045.el @@ -1,4 +1,4 @@ -;;; rfc2045.el --- Functions for decoding rfc2045 headers +;;; rfc2045.el --- Functions for decoding rfc2045 headers -*- lexical-binding:t -*- ;; Copyright (C) 1998-2020 Free Software Foundation, Inc. diff --git a/lisp/mail/rfc2368.el b/lisp/mail/rfc2368.el index 7b38288be20..afa30590059 100644 --- a/lisp/mail/rfc2368.el +++ b/lisp/mail/rfc2368.el @@ -1,4 +1,4 @@ -;;; rfc2368.el --- support for rfc2368 +;;; rfc2368.el --- support for rfc2368 -*- lexical-binding:t -*- ;; Copyright (C) 1998, 2000-2020 Free Software Foundation, Inc. diff --git a/lisp/mail/rmail-spam-filter.el b/lisp/mail/rmail-spam-filter.el index 1755f4eb467..db518482591 100644 --- a/lisp/mail/rmail-spam-filter.el +++ b/lisp/mail/rmail-spam-filter.el @@ -133,7 +133,7 @@ If any element matches the \"From\" header, the message is flagged as a valid, non-spam message. E.g., if your domain is \"emacs.com\" then including \"emacs\\\\.com\" in this list would flag all mail (purporting to be) from your colleagues as valid." - :type '(repeat string) + :type '(repeat regexp) :group 'rmail-spam-filter) (defcustom rsf-definitions-alist nil @@ -157,22 +157,22 @@ A rule matches only if all the specified elements match." (list :format "%v" (cons :format "%v" :value (from . "") (const :format "" from) - (string :tag "From" "")) + (regexp :tag "From" "")) (cons :format "%v" :value (to . "") (const :format "" to) - (string :tag "To" "")) + (regexp :tag "To" "")) (cons :format "%v" :value (subject . "") (const :format "" subject) - (string :tag "Subject" "")) + (regexp :tag "Subject" "")) (cons :format "%v" :value (content-type . "") (const :format "" content-type) - (string :tag "Content-Type" "")) + (regexp :tag "Content-Type" "")) (cons :format "%v" :value (contents . "") (const :format "" contents) - (string :tag "Contents" "")) + (regexp :tag "Contents" "")) (cons :format "%v" :value (x-spam-status . "") (const :format "" x-spam-status) - (string :tag "X-Spam-Status" "")) + (regexp :tag "X-Spam-Status" "")) (cons :format "%v" :value (action . output-and-delete) (const :format "" action) (choice :tag "Action selection" diff --git a/lisp/mail/rmail.el b/lisp/mail/rmail.el index 3feff803e3e..44cde7cb5a9 100644 --- a/lisp/mail/rmail.el +++ b/lisp/mail/rmail.el @@ -578,11 +578,21 @@ Examples: (defvar rmail-reply-prefix "Re: " "String to prepend to Subject line when replying to a message.") +;; Note: this is matched with case-fold-search bound to t. +(defcustom rmail-re-abbrevs + "\\(RE\\|رد\\|回复\\|回覆\\|SV\\|Antw\\|VS\\|REF\\|AW\\|ΑΠ\\|ΣΧΕΤ\\|השב\\|Vá\\|R\\|RIF\\|BLS\\|RES\\|Odp\\|YNT\\|ATB\\)" + "Regexp with localized 'Re:' abbreviations in various languages." + :version "28.1" + :type 'regexp) + ;; Some mailers use "Re(2):" or "Re^2:" or "Re: Re:" or "Re[2]:". ;; This pattern should catch all the common variants. ;; rms: I deleted the change to delete tags in square brackets ;; because they mess up RT tags. -(defvar rmail-reply-regexp "\\`\\(Re\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?: *\\)*" +(defvar rmail-reply-regexp + (concat "\\`\\(" + rmail-re-abbrevs + "\\(([0-9]+)\\|\\[[0-9]+\\]\\|\\^[0-9]+\\)?[::] *\\)*") "Regexp to delete from Subject line before inserting `rmail-reply-prefix'.") (defcustom rmail-display-summary nil @@ -3398,7 +3408,7 @@ whitespace, replacing whitespace runs with a single space and removing prefixes such as Re:, Fwd: and so on and mailing list tags such as [tag]." (let ((subject (or (rmail-get-header "Subject" msgnum) "")) - (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,3\\}:\\|\\[[^]]+]\\)[ \t\n]+\\)*")) + (regexp "\\`[ \t\n]*\\(\\(\\w\\{1,4\\}[::]\\|\\[[^]]+]\\)[ \t\n]+\\)*")) (setq subject (rfc2047-decode-string subject)) (setq subject (replace-regexp-in-string regexp "" subject)) (replace-regexp-in-string "[ \t\n]+" " " subject))) @@ -4393,9 +4403,8 @@ browsing, and moving of messages." (text face mouse function &optional token prevline)) ;; Make sure our special speedbar major mode is loaded -(if (featurep 'speedbar) - (rmail-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'rmail-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (rmail-install-speedbar-variables)) (defun rmail-speedbar-buttons (buffer) "Create buttons for BUFFER containing rmail messages. diff --git a/lisp/man.el b/lisp/man.el index c914ec34b97..3121334c6f9 100644 --- a/lisp/man.el +++ b/lisp/man.el @@ -253,7 +253,7 @@ the associated section number." "Regexp that matches the text that precedes the command's name. Used in `bookmark-set' to get the default bookmark name." :version "24.1" - :type 'string :group 'bookmark) + :type 'regexp :group 'bookmark) (defcustom manual-program "man" "Program used by `man' to produce man pages." @@ -1396,7 +1396,7 @@ synchronously, PROCESS is the name of the buffer where the manpage command is run. Second argument STRING is the entire string of output." (save-excursion (let ((Man-buffer (process-buffer process))) - (if (null (buffer-name Man-buffer)) ;; deleted buffer + (if (not (buffer-live-p Man-buffer)) ;; deleted buffer (set-process-buffer process nil) (with-current-buffer Man-buffer @@ -1430,7 +1430,7 @@ manpage command." (delete-buff nil) message) - (if (null (buffer-name Man-buffer)) ;; deleted buffer + (if (not (buffer-live-p Man-buffer)) ;; deleted buffer (or (stringp process) (set-process-buffer process nil)) diff --git a/lisp/master.el b/lisp/master.el index b0996bf1290..387116a8fbd 100644 --- a/lisp/master.el +++ b/lisp/master.el @@ -3,7 +3,7 @@ ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. ;; Author: Alex Schroeder <alex@gnu.org> -;; Version: 1.0.2 +;; Old-Version: 1.0.2 ;; Keywords: comm ;; This file is part of GNU Emacs. diff --git a/lisp/menu-bar.el b/lisp/menu-bar.el index cc12a17c794..bc094c9050d 100644 --- a/lisp/menu-bar.el +++ b/lisp/menu-bar.el @@ -1476,6 +1476,18 @@ mail status in mode line")) (bindings--define-key menu [cursor-separator] menu-bar-separator) + (bindings--define-key menu [save-desktop] + (menu-bar-make-toggle + toggle-save-desktop-globally desktop-save-mode + "Save State between Sessions" + "Saving desktop state %s" + "Visit desktop of previous session when restarting Emacs" + (require 'desktop) + ;; Do it by name, to avoid a free-variable + ;; warning during byte compilation. + (set-default + 'desktop-save-mode (not (symbol-value 'desktop-save-mode))))) + (bindings--define-key menu [save-place] (menu-bar-make-toggle toggle-save-place-globally save-place-mode @@ -1803,6 +1815,10 @@ mail status in mode line")) (bindings--define-key menu [list-keybindings] '(menu-item "List Key Bindings" describe-bindings :help "Display all current key bindings (keyboard shortcuts)")) + (bindings--define-key menu [list-recent-keystrokes] + '(menu-item "Show Recent Inputs" view-lossage + :help "Display last few input events and the commands \ +they ran")) (bindings--define-key menu [describe-current-display-table] '(menu-item "Describe Display Table" describe-current-display-table :help "Describe the current display table")) diff --git a/lisp/minibuffer.el b/lisp/minibuffer.el index f6e2b236f3e..d2c3f9045e5 100644 --- a/lisp/minibuffer.el +++ b/lisp/minibuffer.el @@ -1968,12 +1968,13 @@ variables.") (plist-get completion-extra-properties :annotation-function) completion-annotate-function)) + (mainbuf (current-buffer)) ;; If the *Completions* buffer is shown in a new ;; window, mark it as softly-dedicated, so bury-buffer in ;; minibuffer-hide-completions will know whether to ;; delete the window or not. (display-buffer-mark-dedicated 'soft)) - (with-displayed-buffer-window + (with-current-buffer-window "*Completions*" ;; This is a copy of `display-buffer-fallback-action' ;; where `display-buffer-use-some-window' is replaced @@ -1987,66 +1988,69 @@ variables.") ,(if (eq (selected-window) (minibuffer-window)) 'display-buffer-at-bottom 'display-buffer-below-selected)) - ,(if temp-buffer-resize-mode - '(window-height . resize-temp-buffer-window) - '(window-height . fit-window-to-buffer)) - ,(when temp-buffer-resize-mode - '(preserve-size . (nil . t)))) - nil - ;; Remove the base-size tail because `sort' requires a properly - ;; nil-terminated list. - (when last (setcdr last nil)) - (setq completions - ;; FIXME: This function is for the output of all-completions, - ;; not completion-all-completions. Often it's the same, but - ;; not always. - (let ((sort-fun (completion-metadata-get - all-md 'display-sort-function))) - (if sort-fun - (funcall sort-fun completions) - (sort completions 'string-lessp)))) - (when afun - (setq completions - (mapcar (lambda (s) - (let ((ann (funcall afun s))) - (if ann (list s ann) s))) - completions))) - - (with-current-buffer standard-output - (set (make-local-variable 'completion-base-position) - (list (+ start base-size) - ;; FIXME: We should pay attention to completion - ;; boundaries here, but currently - ;; completion-all-completions does not give us the - ;; necessary information. - end)) - (set (make-local-variable 'completion-list-insert-choice-function) - (let ((ctable minibuffer-completion-table) - (cpred minibuffer-completion-predicate) - (cprops completion-extra-properties)) - (lambda (start end choice) - (unless (or (zerop (length prefix)) - (equal prefix - (buffer-substring-no-properties - (max (point-min) - (- start (length prefix))) - start))) - (message "*Completions* out of date")) - ;; FIXME: Use `md' to do quoting&terminator here. - (completion--replace start end choice) - (let* ((minibuffer-completion-table ctable) - (minibuffer-completion-predicate cpred) - (completion-extra-properties cprops) - (result (concat prefix choice)) - (bounds (completion-boundaries - result ctable cpred ""))) - ;; If the completion introduces a new field, then - ;; completion is not finished. - (completion--done result - (if (eq (car bounds) (length result)) - 'exact 'finished))))))) - - (display-completion-list completions)))) + ,(if temp-buffer-resize-mode + '(window-height . resize-temp-buffer-window) + '(window-height . fit-window-to-buffer)) + ,(when temp-buffer-resize-mode + '(preserve-size . (nil . t))) + (body-function + . ,#'(lambda (_window) + (with-current-buffer mainbuf + ;; Remove the base-size tail because `sort' requires a properly + ;; nil-terminated list. + (when last (setcdr last nil)) + (setq completions + ;; FIXME: This function is for the output of all-completions, + ;; not completion-all-completions. Often it's the same, but + ;; not always. + (let ((sort-fun (completion-metadata-get + all-md 'display-sort-function))) + (if sort-fun + (funcall sort-fun completions) + (sort completions 'string-lessp)))) + (when afun + (setq completions + (mapcar (lambda (s) + (let ((ann (funcall afun s))) + (if ann (list s ann) s))) + completions))) + + (with-current-buffer standard-output + (set (make-local-variable 'completion-base-position) + (list (+ start base-size) + ;; FIXME: We should pay attention to completion + ;; boundaries here, but currently + ;; completion-all-completions does not give us the + ;; necessary information. + end)) + (set (make-local-variable 'completion-list-insert-choice-function) + (let ((ctable minibuffer-completion-table) + (cpred minibuffer-completion-predicate) + (cprops completion-extra-properties)) + (lambda (start end choice) + (unless (or (zerop (length prefix)) + (equal prefix + (buffer-substring-no-properties + (max (point-min) + (- start (length prefix))) + start))) + (message "*Completions* out of date")) + ;; FIXME: Use `md' to do quoting&terminator here. + (completion--replace start end choice) + (let* ((minibuffer-completion-table ctable) + (minibuffer-completion-predicate cpred) + (completion-extra-properties cprops) + (result (concat prefix choice)) + (bounds (completion-boundaries + result ctable cpred ""))) + ;; If the completion introduces a new field, then + ;; completion is not finished. + (completion--done result + (if (eq (car bounds) (length result)) + 'exact 'finished))))))) + + (display-completion-list completions))))) + nil))) nil)) (defun minibuffer-hide-completions () diff --git a/lisp/misc.el b/lisp/misc.el index 05244a6ea2f..8c39492784b 100644 --- a/lisp/misc.el +++ b/lisp/misc.el @@ -1,4 +1,4 @@ -;;; misc.el --- some nonstandard editing and utility commands for Emacs +;;; misc.el --- some nonstandard editing and utility commands for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1989, 2001-2020 Free Software Foundation, Inc. @@ -162,7 +162,7 @@ Internal use only." "Recompute the list of dynamic libraries. Internal use only." (setq tabulated-list-format ; recomputed because column widths can change - (let ((max-id-len 0) (max-name-len 0)) + (let ((max-id-len 7) (max-name-len 11)) (dolist (lib dynamic-library-alist) (let ((id-len (length (symbol-name (car lib)))) (name-len (apply 'max (mapcar 'length (cdr lib))))) @@ -181,7 +181,9 @@ Internal use only." (push (list id (vector (symbol-name id) (list-dynamic-libraries--loaded from) (mapconcat 'identity (cdr lib) ", "))) - tabulated-list-entries))))) + tabulated-list-entries)))) + (when (not dynamic-library-alist) + (message "No dynamic libraries found"))) ;;;###autoload (defun list-dynamic-libraries (&optional loaded-only-p buffer) diff --git a/lisp/mouse.el b/lisp/mouse.el index e58a2e6da18..640f10af4e1 100644 --- a/lisp/mouse.el +++ b/lisp/mouse.el @@ -552,7 +552,7 @@ frame instead." (not (eq (window-frame minibuffer-window) frame)))) ;; Drag frame when the window is on the bottom of its frame and ;; there is no minibuffer window below. - (mouse-drag-frame start-event 'move))))) + (mouse-drag-frame-move start-event))))) (defun mouse-drag-header-line (start-event) "Change the height of a window by dragging on its header line. @@ -569,7 +569,7 @@ the frame instead." (mouse-drag-line start-event 'header) (let ((frame (window-frame window))) (when (frame-parameter frame 'drag-with-header-line) - (mouse-drag-frame start-event 'move)))))) + (mouse-drag-frame-move start-event)))))) (defun mouse-drag-vertical-line (start-event) "Change the width of a window by dragging on a vertical line. @@ -577,46 +577,7 @@ START-EVENT is the starting mouse event of the drag action." (interactive "e") (mouse-drag-line start-event 'vertical)) -(defun mouse-resize-frame (frame x-diff y-diff &optional x-move y-move) - "Helper function for `mouse-drag-frame'." - (let* ((frame-x-y (frame-position frame)) - (frame-x (car frame-x-y)) - (frame-y (cdr frame-x-y)) - alist) - (if (> x-diff 0) - (when x-move - (setq x-diff (min x-diff frame-x)) - (setq x-move (- frame-x x-diff))) - (let* ((min-width (frame-windows-min-size frame t nil t)) - (min-diff (max 0 (- (frame-inner-width frame) min-width)))) - (setq x-diff (max x-diff (- min-diff))) - (when x-move - (setq x-move (+ frame-x (- x-diff)))))) - - (if (> y-diff 0) - (when y-move - (setq y-diff (min y-diff frame-y)) - (setq y-move (- frame-y y-diff))) - (let* ((min-height (frame-windows-min-size frame nil nil t)) - (min-diff (max 0 (- (frame-inner-height frame) min-height)))) - (setq y-diff (max y-diff (- min-diff))) - (when y-move - (setq y-move (+ frame-y (- y-diff)))))) - - (unless (zerop x-diff) - (when x-move - (push `(left . ,x-move) alist)) - (push `(width . (text-pixels . ,(+ (frame-text-width frame) x-diff))) - alist)) - (unless (zerop y-diff) - (when y-move - (push `(top . ,y-move) alist)) - (push `(height . (text-pixels . ,(+ (frame-text-height frame) y-diff))) - alist)) - (when alist - (modify-frame-parameters frame alist)))) - -(defun mouse-drag-frame (start-event part) +(defun mouse-drag-frame-resize (start-event part) "Drag a frame or one of its edges with the mouse. START-EVENT is the starting mouse event of the drag action. Its position window denotes the frame that will be dragged. @@ -635,9 +596,144 @@ frame with the mouse." (frame (if (window-live-p window) (window-frame window) window)) - (width (frame-native-width frame)) - (height (frame-native-height frame)) - ;; PARENT is the parent frame of FRAME or, if FRAME is a + ;; Initial "first" frame position and size. While dragging we + ;; base all calculations against that size and position. + (first-pos (frame-position frame)) + (first-left (car first-pos)) + (first-top (cdr first-pos)) + (first-width (frame-text-width frame)) + (first-height (frame-text-height frame)) + ;; Don't let FRAME become less large than the size needed to + ;; fit all of its windows. + (min-text-width + (+ (frame-windows-min-size frame t nil t) + (- (frame-inner-width frame) first-width))) + (min-text-height + (+ (frame-windows-min-size frame nil nil t) + (- (frame-inner-height frame) first-height))) + ;; PARENT is the parent frame of FRAME or, if FRAME is a + ;; top-level frame, FRAME's workarea. + (parent (frame-parent frame)) + (parent-edges + (if parent + (frame-edges parent) + (let* ((attributes + (car (display-monitor-attributes-list))) + (workarea (assq 'workarea attributes))) + (and workarea + `(,(nth 1 workarea) ,(nth 2 workarea) + ,(+ (nth 1 workarea) (nth 3 workarea)) + ,(+ (nth 2 workarea) (nth 4 workarea))))))) + (parent-left (and parent-edges (nth 0 parent-edges))) + (parent-top (and parent-edges (nth 1 parent-edges))) + (parent-right (and parent-edges (nth 2 parent-edges))) + (parent-bottom (and parent-edges (nth 3 parent-edges))) + ;; Drag types. drag-left/drag-right and drag-top/drag-bottom + ;; are mutually exclusive. + (drag-left (memq part '(bottom-left left top-left))) + (drag-top (memq part '(top-left top top-right))) + (drag-right (memq part '(top-right right bottom-right))) + (drag-bottom (memq part '(bottom-right bottom bottom-left))) + ;; Initial "first" mouse position. While dragging we base all + ;; calculations against that position. + (first-x-y (mouse-absolute-pixel-position)) + (first-x (car first-x-y)) + (first-y (cdr first-x-y)) + (exitfun nil) + (move + (lambda (event) + (interactive "e") + (when (consp event) + (let* ((last-x-y (mouse-absolute-pixel-position)) + (last-x (car last-x-y)) + (last-y (cdr last-x-y)) + (left (- last-x first-x)) + (top (- last-y first-y)) + alist) + ;; We never want to warp the mouse position here. When + ;; moving the mouse leftward or upward, then with a wide + ;; border the calculated left or top position of the + ;; frame could drop to a value less than zero depending + ;; on where precisely the mouse within the border. We + ;; guard against this by never allowing the frame to + ;; move to a position less than zero here. No such + ;; precautions are used for the right and bottom borders + ;; so with a large internal border parts of that border + ;; may disappear. + (when (and drag-left (>= last-x parent-left) + (>= (- first-width left) min-text-width)) + (push `(left . ,(max (+ first-left left) 0)) alist) + (push `(width . (text-pixels . ,(- first-width left))) + alist)) + (when (and drag-top (>= last-y parent-top) + (>= (- first-height top) min-text-height)) + (push `(top . ,(max 0 (+ first-top top))) alist) + (push `(height . (text-pixels . ,(- first-height top))) + alist)) + (when (and drag-right (<= last-x parent-right) + (>= (+ first-width left) min-text-width)) + (push `(width . (text-pixels . ,(+ first-width left))) + alist)) + (when (and drag-bottom (<= last-y parent-bottom) + (>= (+ first-height top) min-text-height)) + (push `(height . (text-pixels . ,(+ first-height top))) + alist)) + (modify-frame-parameters frame alist))))) + (old-track-mouse track-mouse)) + ;; Start tracking. The special value 'dragging' signals the + ;; display engine to freeze the mouse pointer shape for as long + ;; as we drag. + (setq track-mouse 'dragging) + ;; Loop reading events and sampling the position of the mouse. + (setq exitfun + (set-transient-map + (let ((map (make-sparse-keymap))) + (define-key map [switch-frame] #'ignore) + (define-key map [select-window] #'ignore) + (define-key map [scroll-bar-movement] #'ignore) + (define-key map [mouse-movement] move) + ;; Swallow drag-mouse-1 events to avoid selecting some other window. + (define-key map [drag-mouse-1] + (lambda () (interactive) (funcall exitfun))) + ;; Some of the events will of course end up looked up + ;; with a mode-line, header-line or vertical-line prefix ... + (define-key map [mode-line] map) + (define-key map [header-line] map) + (define-key map [vertical-line] map) + ;; ... and some maybe even with a right- or bottom-divider + ;; prefix. + (define-key map [right-divider] map) + (define-key map [bottom-divider] map) + map) + t (lambda () (setq track-mouse old-track-mouse)))))) + +(defun mouse-drag-frame-move (start-event) + "Drag a frame or one of its edges with the mouse. +START-EVENT is the starting mouse event of the drag action. Its +position window denotes the frame that will be dragged. + +PART specifies the part that has been dragged and must be one of +the symbols `left', `top', `right', `bottom', `top-left', +`top-right', `bottom-left', `bottom-right' to drag an internal +border or edge. If PART equals `move', this means to move the +frame with the mouse." + ;; Give temporary modes such as isearch a chance to turn off. + (run-hooks 'mouse-leave-buffer-hook) + (let* ((echo-keystrokes 0) + (start (event-start start-event)) + (window (posn-window start)) + ;; FRAME is the frame to drag. + (frame (if (window-live-p window) + (window-frame window) + window)) + (native-width (frame-native-width frame)) + (native-height (frame-native-height frame)) + ;; Initial "first" frame position and size. While dragging we + ;; base all calculations against that size and position. + (first-pos (frame-position frame)) + (first-left (car first-pos)) + (first-top (cdr first-pos)) + ;; PARENT is the parent frame of FRAME or, if FRAME is a ;; top-level frame, FRAME's workarea. (parent (frame-parent frame)) (parent-edges @@ -654,19 +750,16 @@ frame with the mouse." (parent-top (and parent-edges (nth 1 parent-edges))) (parent-right (and parent-edges (nth 2 parent-edges))) (parent-bottom (and parent-edges (nth 3 parent-edges))) - ;; `pos-x' and `pos-y' record the x- and y-coordinates of the - ;; last sampled mouse position. Note that we sample absolute - ;; mouse positions to avoid that moving the mouse from one - ;; frame into another gets into our way. `last-x' and `last-y' - ;; records the x- and y-coordinates of the previously sampled - ;; position. The differences between `last-x' and `pos-x' as - ;; well as `last-y' and `pos-y' determine the amount the mouse - ;; has been dragged between the last two samples. - pos-x-y pos-x pos-y - (last-x-y (mouse-absolute-pixel-position)) - (last-x (car last-x-y)) - (last-y (cdr last-x-y)) - ;; `snap-x' and `snap-y' record the x- and y-coordinates of the + ;; Initial "first" mouse position. While dragging we base all + ;; calculations against that position. + (first-x-y (mouse-absolute-pixel-position)) + (first-x (car first-x-y)) + (first-y (cdr first-x-y)) + ;; `snap-width' (maybe also a yet to be provided `snap-height') + ;; could become floats to handle proportionality wrt PARENT. + ;; We don't do any checks on this parameter so far. + (snap-width (frame-parameter frame 'snap-width)) + ;; `snap-x' and `snap-y' record the x- and y-coordinates of the ;; mouse position when FRAME snapped. As soon as the ;; difference between `pos-x' and `snap-x' (or `pos-y' and ;; `snap-y') exceeds the value of FRAME's `snap-width' @@ -678,176 +771,141 @@ frame with the mouse." (lambda (event) (interactive "e") (when (consp event) - (setq pos-x-y (mouse-absolute-pixel-position)) - (setq pos-x (car pos-x-y)) - (setq pos-y (cdr pos-x-y)) - (cond - ((eq part 'left) - (mouse-resize-frame frame (- last-x pos-x) 0 t)) - ((eq part 'top) - (mouse-resize-frame frame 0 (- last-y pos-y) nil t)) - ((eq part 'right) - (mouse-resize-frame frame (- pos-x last-x) 0)) - ((eq part 'bottom) - (mouse-resize-frame frame 0 (- pos-y last-y))) - ((eq part 'top-left) - (mouse-resize-frame - frame (- last-x pos-x) (- last-y pos-y) t t)) - ((eq part 'top-right) - (mouse-resize-frame - frame (- pos-x last-x) (- last-y pos-y) nil t)) - ((eq part 'bottom-left) - (mouse-resize-frame - frame (- last-x pos-x) (- pos-y last-y) t)) - ((eq part 'bottom-right) - (mouse-resize-frame - frame (- pos-x last-x) (- pos-y last-y))) - ((eq part 'move) - (let* ((old-position (frame-position frame)) - (old-left (car old-position)) - (old-top (cdr old-position)) - (left (+ old-left (- pos-x last-x))) - (top (+ old-top (- pos-y last-y))) - right bottom - ;; `snap-width' (maybe also a yet to be provided - ;; `snap-height') could become floats to handle - ;; proportionality wrt PARENT. We don't do any - ;; checks on this parameter so far. - (snap-width (frame-parameter frame 'snap-width))) - ;; Docking and constraining. - (when (and (numberp snap-width) parent-edges) + (let* ((last-x-y (mouse-absolute-pixel-position)) + (last-x (car last-x-y)) + (last-y (cdr last-x-y)) + (left (- last-x first-x)) + (top (- last-y first-y)) + right bottom) + (setq left (+ first-left left)) + (setq top (+ first-top top)) + ;; Docking and constraining. + (when (and (numberp snap-width) parent-edges) + (cond + ;; Docking at the left parent edge. + ((< last-x first-x) (cond - ;; Docking at the left parent edge. - ((< pos-x last-x) - (cond - ((and (> left parent-left) - (<= (- left parent-left) snap-width)) - ;; Snap when the mouse moved leftward and - ;; FRAME's left edge would end up within - ;; `snap-width' pixels from PARENT's left edge. - (setq snap-x pos-x) - (setq left parent-left)) - ((and (<= left parent-left) - (<= (- parent-left left) snap-width) - snap-x (<= (- snap-x pos-x) snap-width)) - ;; Stay snapped when the mouse moved leftward - ;; but not more than `snap-width' pixels from - ;; the time FRAME snapped. - (setq left parent-left)) - (t - ;; Unsnap when the mouse moved more than - ;; `snap-width' pixels leftward from the time - ;; FRAME snapped. - (setq snap-x nil)))) - ((> pos-x last-x) - (setq right (+ left width)) - (cond - ((and (< right parent-right) - (<= (- parent-right right) snap-width)) - ;; Snap when the mouse moved rightward and - ;; FRAME's right edge would end up within - ;; `snap-width' pixels from PARENT's right edge. - (setq snap-x pos-x) - (setq left (- parent-right width))) - ((and (>= right parent-right) - (<= (- right parent-right) snap-width) - snap-x (<= (- pos-x snap-x) snap-width)) - ;; Stay snapped when the mouse moved rightward - ;; but not more more than `snap-width' pixels - ;; from the time FRAME snapped. - (setq left (- parent-right width))) - (t - ;; Unsnap when the mouse moved rightward more - ;; than `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-x nil))))) - + ((and (> left parent-left) + (<= (- left parent-left) snap-width)) + ;; Snap when the mouse moved leftward and FRAME's + ;; left edge would end up within `snap-width' + ;; pixels from PARENT's left edge. + (setq snap-x last-x) + (setq left parent-left)) + ((and (<= left parent-left) + (<= (- parent-left left) snap-width) + snap-x (<= (- snap-x last-x) snap-width)) + ;; Stay snapped when the mouse moved leftward but + ;; not more than `snap-width' pixels from the time + ;; FRAME snapped. + (setq left parent-left)) + (t + ;; Unsnap when the mouse moved more than + ;; `snap-width' pixels leftward from the time + ;; FRAME snapped. + (setq snap-x nil)))) + ((> last-x first-x) + (setq right (+ left native-width)) (cond - ((< pos-y last-y) - (cond - ((and (> top parent-top) - (<= (- top parent-top) snap-width)) - ;; Snap when the mouse moved upward and FRAME's - ;; top edge would end up within `snap-width' - ;; pixels from PARENT's top edge. - (setq snap-y pos-y) - (setq top parent-top)) - ((and (<= top parent-top) - (<= (- parent-top top) snap-width) - snap-y (<= (- snap-y pos-y) snap-width)) - ;; Stay snapped when the mouse moved upward but - ;; not more more than `snap-width' pixels from - ;; the time FRAME snapped. - (setq top parent-top)) - (t - ;; Unsnap when the mouse moved upward more than - ;; `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-y nil)))) - ((> pos-y last-y) - (setq bottom (+ top height)) - (cond - ((and (< bottom parent-bottom) - (<= (- parent-bottom bottom) snap-width)) - ;; Snap when the mouse moved downward and - ;; FRAME's bottom edge would end up within - ;; `snap-width' pixels from PARENT's bottom - ;; edge. - (setq snap-y pos-y) - (setq top (- parent-bottom height))) - ((and (>= bottom parent-bottom) - (<= (- bottom parent-bottom) snap-width) - snap-y (<= (- pos-y snap-y) snap-width)) - ;; Stay snapped when the mouse moved downward - ;; but not more more than `snap-width' pixels - ;; from the time FRAME snapped. - (setq top (- parent-bottom height))) - (t - ;; Unsnap when the mouse moved downward more - ;; than `snap-width' pixels from the time FRAME - ;; snapped. - (setq snap-y nil)))))) - - ;; If requested, constrain FRAME's draggable areas to - ;; PARENT's edges. The `top-visible' parameter should - ;; be set when FRAME has a draggable header-line. If - ;; set to a number, it ascertains that the top of - ;; FRAME is always constrained to the top of PARENT - ;; and that at least as many pixels of FRAME as - ;; specified by that number are visible on each of the - ;; three remaining sides of PARENT. - ;; - ;; The `bottom-visible' parameter should be set when - ;; FRAME has a draggable mode-line. If set to a - ;; number, it ascertains that the bottom of FRAME is - ;; always constrained to the bottom of PARENT and that - ;; at least as many pixels of FRAME as specified by - ;; that number are visible on each of the three - ;; remaining sides of PARENT. - (let ((par (frame-parameter frame 'top-visible)) - bottom-visible) - (unless par - (setq par (frame-parameter frame 'bottom-visible)) - (setq bottom-visible t)) - (when (and (numberp par) parent-edges) - (setq left - (max (min (- parent-right par) left) - (+ (- parent-left width) par))) - (setq top - (if bottom-visible - (min (max top (- parent-top (- height par))) - (- parent-bottom height)) - (min (max top parent-top) - (- parent-bottom par)))))) - - ;; Use `modify-frame-parameters' since `left' and - ;; `top' may want to move FRAME out of its PARENT. - (modify-frame-parameters - frame - `((left . (+ ,left)) (top . (+ ,top))))))) - (setq last-x pos-x) - (setq last-y pos-y)))) - (old-track-mouse track-mouse)) + ((and (< right parent-right) + (<= (- parent-right right) snap-width)) + ;; Snap when the mouse moved rightward and FRAME's + ;; right edge would end up within `snap-width' + ;; pixels from PARENT's right edge. + (setq snap-x last-x) + (setq left (- parent-right native-width))) + ((and (>= right parent-right) + (<= (- right parent-right) snap-width) + snap-x (<= (- last-x snap-x) snap-width)) + ;; Stay snapped when the mouse moved rightward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq left (- parent-right native-width))) + (t + ;; Unsnap when the mouse moved rightward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-x nil))))) + (cond + ((< last-y first-y) + (cond + ((and (> top parent-top) + (<= (- top parent-top) snap-width)) + ;; Snap when the mouse moved upward and FRAME's + ;; top edge would end up within `snap-width' + ;; pixels from PARENT's top edge. + (setq snap-y last-y) + (setq top parent-top)) + ((and (<= top parent-top) + (<= (- parent-top top) snap-width) + snap-y (<= (- snap-y last-y) snap-width)) + ;; Stay snapped when the mouse moved upward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq top parent-top)) + (t + ;; Unsnap when the mouse moved upward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-y nil)))) + ((> last-y first-y) + (setq bottom (+ top native-height)) + (cond + ((and (< bottom parent-bottom) + (<= (- parent-bottom bottom) snap-width)) + ;; Snap when the mouse moved downward and FRAME's + ;; bottom edge would end up within `snap-width' + ;; pixels from PARENT's bottom edge. + (setq snap-y last-y) + (setq top (- parent-bottom native-height))) + ((and (>= bottom parent-bottom) + (<= (- bottom parent-bottom) snap-width) + snap-y (<= (- last-y snap-y) snap-width)) + ;; Stay snapped when the mouse moved downward but + ;; not more more than `snap-width' pixels from the + ;; time FRAME snapped. + (setq top (- parent-bottom native-height))) + (t + ;; Unsnap when the mouse moved downward more than + ;; `snap-width' pixels from the time FRAME + ;; snapped. + (setq snap-y nil)))))) + + ;; If requested, constrain FRAME's draggable areas to + ;; PARENT's edges. The `top-visible' parameter should + ;; be set when FRAME has a draggable header-line. If + ;; set to a number, it ascertains that the top of FRAME + ;; is always constrained to the top of PARENT and that + ;; at least as many pixels of FRAME as specified by that + ;; number are visible on each of the three remaining + ;; sides of PARENT. + ;; + ;; The `bottom-visible' parameter should be set when + ;; FRAME has a draggable mode-line. If set to a number, + ;; it ascertains that the bottom of FRAME is always + ;; constrained to the bottom of PARENT and that at least + ;; as many pixels of FRAME as specified by that number + ;; are visible on each of the three remaining sides of + ;; PARENT. + (let ((par (frame-parameter frame 'top-visible)) + bottom-visible) + (unless par + (setq par (frame-parameter frame 'bottom-visible)) + (setq bottom-visible t)) + (when (and (numberp par) parent-edges) + (setq left + (max (min (- parent-right par) left) + (+ (- parent-left native-width) par))) + (setq top + (if bottom-visible + (min (max top (- parent-top (- native-height par))) + (- parent-bottom native-height)) + (min (max top parent-top) + (- parent-bottom par)))))) + ;; Use `modify-frame-parameters' since `left' and `top' + ;; may want to move FRAME out of its PARENT. + (modify-frame-parameters frame `((left . (+ ,left)) (top . (+ ,top)))))))) + (old-track-mouse track-mouse)) ;; Start tracking. The special value 'dragging' signals the ;; display engine to freeze the mouse pointer shape for as long ;; as we drag. @@ -879,49 +937,49 @@ frame with the mouse." "Drag left edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'left)) + (mouse-drag-frame-resize start-event 'left)) (defun mouse-drag-top-left-corner (start-event) "Drag top left corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top-left)) + (mouse-drag-frame-resize start-event 'top-left)) (defun mouse-drag-top-edge (start-event) "Drag top edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top)) + (mouse-drag-frame-resize start-event 'top)) (defun mouse-drag-top-right-corner (start-event) "Drag top right corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'top-right)) + (mouse-drag-frame-resize start-event 'top-right)) (defun mouse-drag-right-edge (start-event) "Drag right edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'right)) + (mouse-drag-frame-resize start-event 'right)) (defun mouse-drag-bottom-right-corner (start-event) "Drag bottom right corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom-right)) + (mouse-drag-frame-resize start-event 'bottom-right)) (defun mouse-drag-bottom-edge (start-event) "Drag bottom edge of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom)) + (mouse-drag-frame-resize start-event 'bottom)) (defun mouse-drag-bottom-left-corner (start-event) "Drag bottom left corner of a frame with the mouse. START-EVENT is the starting mouse event of the drag action." (interactive "e") - (mouse-drag-frame start-event 'bottom-left)) + (mouse-drag-frame-resize start-event 'bottom-left)) (defcustom mouse-select-region-move-to-beginning nil "Effect of selecting a region extending backward from double click. @@ -2498,7 +2556,7 @@ region, text is copied instead of being cut." (lambda (modifier) `(const :tag ,(format "Enable, but copy with the %s modifier" modifier) - modifier)) + ,modifier)) '(alt super hyper shift control meta)) (other :tag "Enable dragging the region" t)) :version "26.1") @@ -2517,9 +2575,12 @@ as it does when dropping text in the source buffer." If this option is nil, `mouse-drag-and-drop-region' does not show tooltips. If this is t, it shows the entire text dragged in a tooltip. If this is an integer (as with the default value of -256), it will show that many characters of the dragged text in -a tooltip." - :type 'integer +256), it will show up to that many characters of the dragged text +in a tooltip." + :type '(choice + (const :tag "Do not show tooltips" nil) + (const :tag "Show all text" t) + (integer :tag "Max number of characters to show" 256)) :version "26.1") (defcustom mouse-drag-and-drop-region-show-cursor t @@ -2553,6 +2614,7 @@ is copied instead of being cut." (let* ((mouse-button (event-basic-type last-input-event)) (mouse-drag-and-drop-region-show-tooltip (when (and mouse-drag-and-drop-region-show-tooltip + (> mouse-drag-and-drop-region-show-tooltip 0) (display-multi-frame-p) (require 'tooltip)) mouse-drag-and-drop-region-show-tooltip)) diff --git a/lisp/msb.el b/lisp/msb.el index ebaf98cbe83..15aeaa2e73f 100644 --- a/lisp/msb.el +++ b/lisp/msb.el @@ -372,6 +372,8 @@ This is instead of the groups in `msb-menu-cond'." :type 'hook :set 'msb-custom-set :group 'msb) +(make-obsolete-variable 'msb-after-load-hook + "use `with-eval-after-load' instead." "28.1") ;;; ;;; Internal variables diff --git a/lisp/net/ange-ftp.el b/lisp/net/ange-ftp.el index 92ed98b2a89..0cb8d7cb837 100644 --- a/lisp/net/ange-ftp.el +++ b/lisp/net/ange-ftp.el @@ -838,7 +838,7 @@ If nil, prompt the user for a password." "If non-nil, regexp matching hosts on which `dir' command lists directory." :group 'ange-ftp :type '(choice (const :tag "Default" nil) - string)) + regexp)) (defcustom ange-ftp-binary-file-name-regexp "" "If a file matches this regexp then it is transferred in binary mode." @@ -4169,8 +4169,7 @@ directory, so that Emacs will know its current contents." (if (file-directory-p file) (ange-ftp-delete-directory file recursive trash) (delete-file file trash))) - ;; We do not want to delete "." and "..". - (directory-files dir 'full (rx (or (not ".") "..."))))) + (directory-files dir 'full directory-files-no-dot-files-regexp))) (if parsed (let* ((host (nth 0 parsed)) (user (nth 1 parsed)) @@ -4739,7 +4738,8 @@ NEWNAME should be the name to give the new compressed or uncompressed file.") (setq ange-ftp-ls-cache-file nil) ;Stop confusing Dired. 0) -(defun ange-ftp-set-file-modes (filename mode) +(defun ange-ftp-set-file-modes (filename mode &optional flag) + flag ;; FIXME: Support 'nofollow'. (ange-ftp-call-chmod (list (format "%o" mode) filename))) (defun ange-ftp-make-symbolic-link (&rest _arguments) diff --git a/lisp/net/browse-url.el b/lisp/net/browse-url.el index 25aabf6d61d..8892e800cd6 100644 --- a/lisp/net/browse-url.el +++ b/lisp/net/browse-url.el @@ -39,7 +39,6 @@ ;; browse-url-chrome Chrome 47.0.2526.111 ;; browse-url-chromium Chromium 3.0 ;; browse-url-epiphany Epiphany Don't know -;; browse-url-conkeror Conkeror Don't know ;; browse-url-w3 w3 0 ;; browse-url-text-* Any text browser 0 ;; browse-url-generic arbitrary @@ -114,9 +113,23 @@ ;; To always save modified buffers before displaying the file in a browser: ;; (setq browse-url-save-file t) -;; To invoke different browsers for different URLs: -;; (setq browse-url-browser-function '(("^mailto:" . browse-url-mail) -;; ("." . browse-url-firefox))) +;; To invoke different browsers/tools for different URLs, customize +;; `browse-url-handlers'. In earlier versions of Emacs, the same +;; could be done by setting `browse-url-browser-function' to an alist +;; but this usage is deprecated now. + +;; All browser functions provided by here have a +;; `browse-url-browser-kind' symbol property set to either `internal' +;; or `external' which determines if they browse the given URL inside +;; Emacs or spawn an external application with it. Some parts of +;; Emacs make use of that, e.g., when an URL is dragged into Emacs, it +;; is not sensible to invoke an external browser with it, so here only +;; internal browsers are considered. Therefore, it is advised to put +;; that property also on custom browser functions. +;; (function-put 'my-browse-url-in-emacs 'browse-url-browser-kind +;; 'internal) +;; (function-put 'my-browse-url-externally 'browse-url-browser-kind +;; 'external) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Code: @@ -140,7 +153,6 @@ (function-item :tag "Google Chrome" :value browse-url-chrome) (function-item :tag "Chromium" :value browse-url-chromium) (function-item :tag "Epiphany" :value browse-url-epiphany) - (function-item :tag "Conkeror" :value browse-url-conkeror) (function-item :tag "Text browser in an xterm window" :value browse-url-text-xterm) (function-item :tag "Text browser in an Emacs window" @@ -157,7 +169,9 @@ :value browse-url-default-browser) (function :tag "Your own function") (alist :tag "Regexp/function association list" - :key-type regexp :value-type function))) + :key-type regexp :value-type function + :format "%{%t%}\n%d%v\n" + :doc "Deprecated. Use `browse-url-handlers' instead."))) ;;;###autoload (defcustom browse-url-browser-function 'browse-url-default-browser @@ -165,13 +179,8 @@ This is used by the `browse-url-at-point', `browse-url-at-mouse', and `browse-url-of-file' commands. -If the value is not a function it should be a list of pairs -\(REGEXP . FUNCTION). In this case the function called will be the one -associated with the first REGEXP which matches the current URL. The -function is passed the URL and any other args of `browse-url'. The last -regexp should probably be \".\" to specify a default browser. - -Also see `browse-url-secondary-browser-function'." +Also see `browse-url-secondary-browser-function' and +`browse-url-handlers'." :type browse-url--browser-defcustom-type :version "24.1") @@ -216,7 +225,7 @@ be used instead." "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: ;; http://thread.gmane.org/47B4E3B2.3050402@gmail.com - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "\\(?:" "[" chars punct "]+" "[" chars "]" "\\)?" "\\|" "[" chars punct "]+" "[" chars "]" @@ -385,6 +394,8 @@ If non-nil, then open the URL in a new buffer rather than a new window if :version "25.1" :type 'boolean) +(make-obsolete-variable 'browse-url-conkeror-new-window-is-buffer nil "28.1") + (defcustom browse-url-galeon-new-window-is-tab nil "Whether to open up new windows in a tab or a new window. If non-nil, then open the URL in a new tab rather than a new window if @@ -438,11 +449,15 @@ commands reverses the effect of this variable." :type 'string :version "25.1") +(make-obsolete-variable 'browse-url-conkeror-program nil "28.1") + (defcustom browse-url-conkeror-arguments nil "A list of strings to pass to Conkeror as arguments." :version "25.1" :type '(repeat (string :tag "Argument"))) +(make-obsolete-variable 'browse-url-conkeror-arguments nil "28.1") + (defcustom browse-url-filename-alist `(("^/\\(ftp@\\|anonymous@\\)?\\([^:/]+\\):/*" . "ftp://\\2/") ;; The above loses the username to avoid the browser prompting for @@ -595,6 +610,116 @@ down (this *won't* always work)." "Wrapper command prepended to the Elinks command-line." :type '(repeat (string :tag "Wrapper"))) +(defun browse-url--browser-kind (function url) + "Return the browser kind of a browser FUNCTION for URL. +The browser kind is either `internal' (the browser runs inside +Emacs), `external' (the browser is spawned in an external +process), or nil (we don't know)." + (let ((kind (if (symbolp function) + (get function 'browse-url-browser-kind)))) + (if (functionp kind) + (funcall kind url) + kind))) + +(defun browse-url--mailto (url &rest args) + "Calls `browse-url-mailto-function' with URL and ARGS." + (funcall browse-url-mailto-function url args)) + +(defun browse-url--browser-kind-mailto (url) + (browse-url--browser-kind browse-url-mailto-function url)) +(function-put 'browse-url--mailto 'browse-url-browser-kind + #'browse-url--browser-kind-mailto) + +(defun browse-url--man (url &rest args) + "Calls `browse-url-man-function' with URL and ARGS." + (funcall browse-url-man-function url args)) + +(defun browse-url--browser-kind-man (url) + (browse-url--browser-kind browse-url-man-function url)) +(function-put 'browse-url--man 'browse-url-browser-kind + #'browse-url--browser-kind-man) + +(defun browse-url--browser (url &rest args) + "Calls `browse-url-browser-function' with URL and ARGS." + (funcall browse-url-browser-function url args)) + +(defun browse-url--browser-kind-browser (url) + (browse-url--browser-kind browse-url-browser-function url)) +(function-put 'browse-url--browser 'browse-url-browser-kind + #'browse-url--browser-kind-browser) + +(defun browse-url--non-html-file-url-p (url) + "Return non-nil if URL is a file:// URL of a non-HTML file." + (and (string-match-p "\\`file://" url) + (not (string-match-p "\\`file://.*\\.html?\\b" url)))) + +;;;###autoload +(defvar browse-url-default-handlers + '(("\\`mailto:" . browse-url--mailto) + ("\\`man:" . browse-url--man) + (browse-url--non-html-file-url-p . browse-url-emacs)) + "Like `browse-url-handlers' but populated by Emacs and packages. + +Emacs and external packages capable of browsing certain URLs +should place their entries in this alist rather than +`browse-url-handlers' which is reserved for the user.") + +(defcustom browse-url-handlers nil + "An alist with elements of the form (REGEXP-OR-PREDICATE . HANDLER). +Each REGEXP-OR-PREDICATE is matched against the URL to be opened +in turn and the first match's HANDLER is invoked with the URL. + +A HANDLER must be a function with the same arguments as +`browse-url'. + +If no REGEXP-OR-PREDICATE matches, the same procedure is +performed with the value of `browse-url-default-handlers'. If +there is also no match, the URL is opened using the value of +`browse-url-browser-function'." + :type '(alist :key-type (choice + (regexp :tag "Regexp") + (function :tag "Predicate")) + :value-type (function :tag "Handler")) + :version "28.1") + +;;;###autoload +(defun browse-url-select-handler (url &optional kind) + "Return a handler of suitable for browsing URL. +This searches `browse-url-handlers', and +`browse-url-default-handlers' for a matching handler. Return nil +if no handler is found. + +If KIND is given, the search is restricted to handlers whose +function symbol has the symbol-property `browse-url-browser-kind' +set to KIND. + +Currently, it also consults `browse-url-browser-function' first +if it is set to an alist, although this usage is deprecated since +Emacs 28.1 and will be removed in a future release." + (catch 'custom-url-handler + (dolist (rxpred-handler + (append + ;; The alist choice of browse-url-browser-function + ;; is deprecated since 28.1, so the (unless ...) + ;; can be removed at some point in time. + (when (and (consp browse-url-browser-function) + (not (functionp browse-url-browser-function))) + (lwarn 'browse-url :warning + "Having `browse-url-browser-function' set to an +alist is deprecated. Use `browse-url-handlers' instead.") + browse-url-browser-function) + browse-url-handlers + browse-url-default-handlers)) + (let ((rx-or-pred (car rxpred-handler)) + (handler (cdr rxpred-handler))) + (when (and (or (null kind) + (eq kind (browse-url--browser-kind + handler url))) + (if (functionp rx-or-pred) + (funcall rx-or-pred url) + (string-match-p rx-or-pred url))) + (throw 'custom-url-handler handler)))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; URL encoding @@ -768,16 +893,18 @@ narrowed." "Ask a WWW browser to load URL. Prompt for a URL, defaulting to the URL at or before point. Invokes a suitable browser function which does the actual job. -The variable `browse-url-browser-function' says which browser function to -use. If the URL is a mailto: URL, consult `browse-url-mailto-function' -first, if that exists. - -The additional ARGS are passed to the browser function. See the doc -strings of the actual functions, starting with `browse-url-browser-function', -for information about the significance of ARGS (most of the functions -ignore it). -If ARGS are omitted, the default is to pass `browse-url-new-window-flag' -as ARGS." + +The variables `browse-url-browser-function', +`browse-url-handlers', and `browse-url-default-handlers' +determine which browser function to use. + +The additional ARGS are passed to the browser function. See the +doc strings of the actual functions, starting with +`browse-url-browser-function', for information about the +significance of ARGS (most of the functions ignore it). + +If ARGS are omitted, the default is to pass +`browse-url-new-window-flag' as ARGS." (interactive (browse-url-interactive-arg "URL: ")) (unless (called-interactively-p 'interactive) (setq args (or args (list browse-url-new-window-flag)))) @@ -786,12 +913,9 @@ as ARGS." (not (string-match "\\`[a-z]+:" url))) (setq url (expand-file-name url))) (let ((process-environment (copy-sequence process-environment)) - (function (or (and (string-match "\\`mailto:" url) - browse-url-mailto-function) - (and (string-match "\\`man:" url) - browse-url-man-function) - browse-url-browser-function)) - ;; Ensure that `default-directory' exists and is readable (b#6077). + (function (or (browse-url-select-handler url) + browse-url-browser-function)) + ;; Ensure that `default-directory' exists and is readable (bug#6077). (default-directory (or (unhandled-file-name-directory default-directory) (expand-file-name "~/")))) ;; When connected to various displays, be careful to use the display of @@ -799,20 +923,9 @@ as ARGS." ;; which may not even exist any more. (if (stringp (frame-parameter nil 'display)) (setenv "DISPLAY" (frame-parameter nil 'display))) - (if (and (consp function) - (not (functionp function))) - ;; The `function' can be an alist; look down it for first match - ;; and apply the function (which might be a lambda). - (catch 'done - (dolist (bf function) - (when (string-match (car bf) url) - (apply (cdr bf) url args) - (throw 'done t))) - (error "No browse-url-browser-function matching URL %s" - url)) - ;; Unbound symbols go down this leg, since void-function from - ;; apply is clearer than wrong-type-argument from dolist. - (apply function url args)))) + (if (functionp function) + (apply function url args) + (error "No suitable browser for URL %s" url)))) ;;;###autoload (defun browse-url-at-point (&optional arg) @@ -829,6 +942,34 @@ Optional prefix argument ARG non-nil inverts the value of the option (error "No URL found")))) ;;;###autoload +(defun browse-url-with-browser-kind (kind url &optional arg) + "Browse URL with a browser of the given browser KIND. +KIND is either `internal' or `external'. + +When called interactively, the default browser kind is the +opposite of the browser kind of `browse-url-browser-function'." + (interactive + (let* ((url-arg (browse-url-interactive-arg "URL: ")) + ;; Default to the inverse kind of the default browser. + (default (if (eq (browse-url--browser-kind + browse-url-browser-function (car url-arg)) + 'internal) + 'external + 'internal)) + (k (intern (completing-read + (format "Browser kind (default %s): " default) + '(internal external) + nil t nil nil + default)))) + (cons k url-arg))) + (let ((function (browse-url-select-handler url kind))) + (unless function + (setq function (if (eq kind 'external) + #'browse-url-default-browser + #'eww))) + (funcall function url arg))) + +;;;###autoload (defun browse-url-at-mouse (event) "Ask a WWW browser to load a URL clicked with the mouse. The URL is the one around or before the position of the mouse click @@ -875,12 +1016,18 @@ The optional NEW-WINDOW argument is not used." (url-unhex-string url) url))))) +(function-put 'browse-url-default-windows-browser 'browse-url-browser-kind + 'external) + (defun browse-url-default-macosx-browser (url &optional _new-window) "Invoke the macOS system's default Web browser. The optional NEW-WINDOW argument is not used." (interactive (browse-url-interactive-arg "URL: ")) (start-process (concat "open " url) nil "open" url)) +(function-put 'browse-url-default-macosx-browser 'browse-url-browser-kind + 'external) + ;; --- Netscape --- (defun browse-url-process-environment () @@ -929,7 +1076,7 @@ instead of `browse-url-new-window-flag'." ((executable-find browse-url-kde-program) 'browse-url-kde) ;;; ((executable-find browse-url-netscape-program) 'browse-url-netscape) ;;; ((executable-find browse-url-mosaic-program) 'browse-url-mosaic) - ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) +;;; ((executable-find browse-url-conkeror-program) 'browse-url-conkeror) ((executable-find browse-url-chrome-program) 'browse-url-chrome) ((executable-find browse-url-xterm-program) 'browse-url-text-xterm) ((locate-library "w3") 'browse-url-w3) @@ -937,6 +1084,10 @@ instead of `browse-url-new-window-flag'." (lambda (&rest _ignore) (error "No usable browser found")))) url args)) +(function-put 'browse-url-default-browser 'browse-url-browser-kind + ;; Well, most probably external if we ignore w3. + 'external) + (defun browse-url-can-use-xdg-open () "Return non-nil if the \"xdg-open\" program can be used. xdg-open is a desktop utility that calls your preferred web browser." @@ -956,6 +1107,8 @@ The optional argument IGNORED is not used." (interactive (browse-url-interactive-arg "URL: ")) (call-process "xdg-open" nil 0 nil url)) +(function-put 'browse-url-xdg-open 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-netscape (url &optional new-window) "Ask the Netscape WWW browser to load URL. @@ -999,6 +1152,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-netscape-sentinel process ,url))))) +(function-put 'browse-url-netscape 'browse-url-browser-kind 'external) + (defun browse-url-netscape-sentinel (process url) "Handle a change to the process communicating with Netscape." (declare (obsolete nil "25.1")) @@ -1069,6 +1224,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-mozilla-sentinel process ,url))))) +(function-put 'browse-url-mozilla 'browse-url-browser-kind 'external) + (defun browse-url-mozilla-sentinel (process url) "Handle a change to the process communicating with Mozilla." (or (eq (process-exit-status process) 0) @@ -1109,6 +1266,8 @@ instead of `browse-url-new-window-flag'." '("-new-window"))) (list url))))) +(function-put 'browse-url-firefox 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-chromium (url &optional _new-window) "Ask the Chromium WWW browser to load URL. @@ -1126,6 +1285,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chromium-arguments (list url))))) +(function-put 'browse-url-chromium 'browse-url-browser-kind 'external) + (defun browse-url-chrome (url &optional _new-window) "Ask the Google Chrome WWW browser to load URL. Default to the URL around or before point. The strings in @@ -1142,6 +1303,8 @@ The optional argument NEW-WINDOW is not used." browse-url-chrome-arguments (list url))))) +(function-put 'browse-url-chrome 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-galeon (url &optional new-window) "Ask the Galeon WWW browser to load URL. @@ -1179,6 +1342,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-galeon-sentinel process ,url))))) +(function-put 'browse-url-galeon 'browse-url-browser-kind 'external) + (defun browse-url-galeon-sentinel (process url) "Handle a change to the process communicating with Galeon." (declare (obsolete nil "25.1")) @@ -1225,6 +1390,8 @@ used instead of `browse-url-new-window-flag'." `(lambda (process change) (browse-url-epiphany-sentinel process ,url))))) +(function-put 'browse-url-epiphany 'browse-url-browser-kind 'external) + (defun browse-url-epiphany-sentinel (process url) "Handle a change to the process communicating with Epiphany." (or (eq (process-exit-status process) 0) @@ -1249,6 +1416,8 @@ currently selected window instead." file-name-handler-alist))) (if same-window (find-file url) (find-file-other-window url)))) +(function-put 'browse-url-emacs 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-gnome-moz (url &optional new-window) "Ask Mozilla/Netscape to load URL via the GNOME program `gnome-moz-remote'. @@ -1273,6 +1442,8 @@ used instead of `browse-url-new-window-flag'." '("--newwin")) (list "--raise" url)))) +(function-put 'browse-url-gnome-moz 'browse-url-browser-kind 'external) + ;; --- Mosaic --- ;;;###autoload @@ -1324,6 +1495,8 @@ used instead of `browse-url-new-window-flag'." (append browse-url-mosaic-arguments (list url))) (message "Starting %s...done" browse-url-mosaic-program)))) +(function-put 'browse-url-mosaic 'browse-url-browser-kind 'external) + ;; --- Mosaic using CCI --- ;;;###autoload @@ -1356,6 +1529,8 @@ used instead of `browse-url-new-window-flag'." (process-send-string "browse-url" "disconnect\r\n") (delete-process "browse-url")) +(function-put 'browse-url-cci 'browse-url-browser-kind 'external) + ;; --- Conkeror --- ;;;###autoload (defun browse-url-conkeror (url &optional new-window) @@ -1375,6 +1550,7 @@ new window, load it in a new buffer in an existing window instead. When called non-interactively, use optional second argument NEW-WINDOW instead of `browse-url-new-window-flag'." + (declare (obsolete nil "28.1")) (interactive (browse-url-interactive-arg "URL: ")) (setq url (browse-url-encode-url url)) (let* ((process-environment (browse-url-process-environment))) @@ -1392,6 +1568,9 @@ NEW-WINDOW instead of `browse-url-new-window-flag'." "window") "buffer") url)))))) + +(function-put 'browse-url-conkeror 'browse-url-browser-kind 'external) + ;; --- W3 --- ;; External. @@ -1415,6 +1594,8 @@ used instead of `browse-url-new-window-flag'." (w3-fetch-other-window url) (w3-fetch url))) +(function-put 'browse-url-w3 'browse-url-browser-kind 'internal) + ;;;###autoload (defun browse-url-w3-gnudoit (url &optional _new-window) ;; new-window ignored @@ -1429,6 +1610,8 @@ The `browse-url-gnudoit-program' program is used with options given by (list (concat "(w3-fetch \"" url "\")") "(raise-frame)")))) +(function-put 'browse-url-w3-gnudoit 'browse-url-browser-kind 'internal) + ;; --- Lynx in an xterm --- ;;;###autoload @@ -1446,6 +1629,8 @@ The optional argument NEW-WINDOW is not used." ,@browse-url-xterm-args "-e" ,browse-url-text-browser ,url))) +(function-put 'browse-url-text-xterm 'browse-url-browser-kind 'external) + ;; --- Lynx in an Emacs "term" window --- (declare-function term-char-mode "term" ()) @@ -1520,6 +1705,8 @@ used instead of `browse-url-new-window-flag'." url "\r"))))) +(function-put 'browse-url-text-emacs 'browse-url-browser-kind 'internal) + ;; --- mailto --- (autoload 'rfc2368-parse-mailto-url "rfc2368") @@ -1567,6 +1754,8 @@ used instead of `browse-url-new-window-flag'." (unless (bolp) (insert "\n")))))))) +(function-put 'browse-url-mail 'browse-url-browser-kind 'internal) + ;; --- man --- (defvar manual-program) @@ -1578,7 +1767,9 @@ used instead of `browse-url-new-window-flag'." (setq url (replace-regexp-in-string "\\`man:" "" url)) (cond ((executable-find manual-program) (man url)) - (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + (t (woman (replace-regexp-in-string "([[:alnum:]]+)" "" url))))) + +(function-put 'browse-url-man 'browse-url-browser-kind 'internal) ;; --- Random browser --- @@ -1597,6 +1788,8 @@ don't offer a form of remote control." 0 nil (append browse-url-generic-args (list url)))) +(function-put 'browse-url-generic 'browse-url-browser-kind 'external) + ;;;###autoload (defun browse-url-kde (url &optional _new-window) "Ask the KDE WWW browser to load URL. @@ -1607,6 +1800,8 @@ The optional argument NEW-WINDOW is not used." (apply #'start-process (concat "KDE " url) nil browse-url-kde-program (append browse-url-kde-args (list url)))) +(function-put 'browse-url-kde 'browse-url-browser-kind 'external) + (defun browse-url-elinks-new-window (url) "Ask the Elinks WWW browser to load URL in a new window." (let ((process-environment (browse-url-process-environment))) @@ -1616,6 +1811,9 @@ The optional argument NEW-WINDOW is not used." browse-url-elinks-wrapper (list "elinks" url))))) +(function-put 'browse-url-elinks-new-window 'browse-url-browser-kind + 'external) + ;;;###autoload (defun browse-url-elinks (url &optional new-window) "Ask the Elinks WWW browser to load URL. @@ -1637,6 +1835,8 @@ from `browse-url-elinks-wrapper'." `(lambda (process change) (browse-url-elinks-sentinel process ,url)))))) +(function-put 'browse-url-elinks 'browse-url-browser-kind 'external) + (defun browse-url-elinks-sentinel (process url) "Determines if Elinks is running or a new one has to be started." ;; Try to determine if an instance is running or if we have to diff --git a/lisp/net/dbus.el b/lisp/net/dbus.el index 06bd9e567fe..fdd726ff613 100644 --- a/lisp/net/dbus.el +++ b/lisp/net/dbus.el @@ -51,9 +51,6 @@ (unless (boundp 'dbus-debug) (defvar dbus-debug nil)) -;; Pacify byte compiler. -(eval-when-compile (require 'cl-lib)) - (require 'xml) (defconst dbus-service-dbus "org.freedesktop.DBus" @@ -169,10 +166,7 @@ Otherwise, return result of last form in BODY, or all other errors." `(condition-case err (progn ,@body) (dbus-error (when dbus-debug (signal (car err) (cdr err)))))) -(font-lock-add-keywords 'emacs-lisp-mode '("\\<dbus-ignore-errors\\>")) -(define-obsolete-variable-alias 'dbus-event-error-hooks - 'dbus-event-error-functions "24.3") (defvar dbus-event-error-functions '(dbus-notice-synchronous-call-errors) "Functions to be called when a D-Bus error happens in the event handler. Every function must accept two arguments, the event and the error variable @@ -181,7 +175,7 @@ caught in `condition-case' by `dbus-error'.") ;;; Basic D-Bus message functions. -(defvar dbus-return-values-table (make-hash-table :test 'equal) +(defvar dbus-return-values-table (make-hash-table :test #'equal) "Hash table for temporarily storing arguments of reply messages. A key in this hash table is a list (:serial BUS SERIAL), like in `dbus-registered-objects-table'. BUS is either a Lisp symbol, @@ -301,8 +295,8 @@ object is returned instead of a list containing this single Lisp object. (check-interval 0.001) (key (apply - 'dbus-message-internal dbus-message-type-method-call - bus service path interface method 'dbus-call-method-handler args)) + #'dbus-message-internal dbus-message-type-method-call + bus service path interface method #'dbus-call-method-handler args)) (result (cons :pending nil))) ;; Wait until `dbus-call-method-handler' has put the result into @@ -338,10 +332,6 @@ object is returned instead of a list containing this single Lisp object. (cdr result)) (remhash key dbus-return-values-table)))) -;; `dbus-call-method' works non-blocking now. -(defalias 'dbus-call-method-non-blocking 'dbus-call-method) -(make-obsolete 'dbus-call-method-non-blocking 'dbus-call-method "24.3") - (defun dbus-call-method-asynchronously (bus service path interface method handler &rest args) "Call METHOD on the D-Bus BUS asynchronously. @@ -406,7 +396,7 @@ Example: (or (null handler) (functionp handler) (signal 'wrong-type-argument (list 'functionp handler))) - (apply 'dbus-message-internal dbus-message-type-method-call + (apply #'dbus-message-internal dbus-message-type-method-call bus service path interface method handler args)) (defun dbus-send-signal (bus service path interface signal &rest args) @@ -454,7 +444,7 @@ Example: (or (stringp signal) (signal 'wrong-type-argument (list 'stringp signal))) - (apply 'dbus-message-internal dbus-message-type-signal + (apply #'dbus-message-internal dbus-message-type-signal bus service path interface signal args)) (defun dbus-method-return-internal (bus service serial &rest args) @@ -470,7 +460,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-method-return + (apply #'dbus-message-internal dbus-message-type-method-return bus service serial args)) (defun dbus-method-error-internal (bus service serial &rest args) @@ -486,7 +476,7 @@ This is an internal function, it shall not be used outside dbus.el." (or (natnump serial) (signal 'wrong-type-argument (list 'natnump serial))) - (apply 'dbus-message-internal dbus-message-type-error + (apply #'dbus-message-internal dbus-message-type-error bus service serial args)) @@ -552,13 +542,13 @@ placed in the queue. `:already-owner': Service is already the primary owner." ;; Add Peer handler. - (dbus-register-method - bus service nil dbus-interface-peer "Ping" 'dbus-peer-handler 'dont-register) + (dbus-register-method bus service nil dbus-interface-peer "Ping" + #'dbus-peer-handler 'dont-register) ;; Add ObjectManager handler. (dbus-register-method bus service nil dbus-interface-objectmanager "GetManagedObjects" - 'dbus-managed-objects-handler 'dont-register) + #'dbus-managed-objects-handler 'dont-register) (let ((arg 0) reply) @@ -681,7 +671,7 @@ Example: (if (and (stringp service) (not (zerop (length service))) (not (string-equal service dbus-service-dbus)) - (not (string-match "^:" service))) + (/= (string-to-char service) ?:)) (setq uname (dbus-get-name-owner bus service)) (setq uname service)) @@ -710,7 +700,7 @@ Example: ;; `:arg0' .. `:arg63', `:path0' .. `:path63'. ((and (keywordp key) (string-match - "^:\\(arg\\|path\\)\\([[:digit:]]+\\)$" + "\\`:\\(arg\\|path\\)\\([[:digit:]]+\\)\\'" (symbol-name key))) (setq counter (match-string 2 (symbol-name key)) args (cdr args) @@ -726,9 +716,7 @@ Example: "path" "") value)) ;; `:arg-namespace', `:path-namespace'. - ((and (keywordp key) - (string-match - "^:\\(arg\\|path\\)-namespace$" (symbol-name key))) + ((memq key '(:arg-namespace :path-namespace)) (setq args (cdr args) value (car args)) (unless (stringp value) @@ -736,8 +724,7 @@ Example: (list "Wrong argument" key value))) (format ",%s='%s'" - (if (string-equal (match-string 1 (symbol-name key)) "path") - "path_namespace" "arg0namespace") + (if (eq key :path-namespace) "path_namespace" "arg0namespace") value)) ;; `:eavesdrop'. ((eq key :eavesdrop) @@ -751,11 +738,11 @@ Example: bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule) (dbus-error - (if (not (string-match "eavesdrop" rule)) + (if (not (string-match-p "eavesdrop" rule)) (signal (car err) (cdr err)) ;; The D-Bus spec says we shall fall back to a rule without eavesdrop. (when dbus-debug (message "Removing eavesdrop from rule %s" rule)) - (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule)) + (setq rule (replace-regexp-in-string ",eavesdrop='true'" "" rule t t)) (dbus-call-method bus dbus-service-dbus dbus-path-dbus dbus-interface-dbus "AddMatch" rule)))) @@ -893,9 +880,7 @@ association to the service from D-Bus." STRING shall be UTF-8 coded." (if (zerop (length string)) '(:array :signature "y") - (let (result) - (dolist (elt (string-to-list string) (append '(:array) result)) - (setq result (append result (list :byte elt))))))) + (cons :array (mapcan (lambda (c) (list :byte c)) string)))) (defun dbus-byte-array-to-string (byte-array &optional multibyte) "Transform BYTE-ARRAY into UTF-8 coded string. @@ -903,12 +888,9 @@ BYTE-ARRAY must be a list of structure (c1 c2 ...), or a byte array as produced by `dbus-string-to-byte-array'. The resulting string is unibyte encoded, unless MULTIBYTE is non-nil." (apply - (if multibyte 'string 'unibyte-string) - (if (equal byte-array '(:array :signature "y")) - nil - (let (result) - (dolist (elt byte-array result) - (when (characterp elt) (setq result (append result `(,elt))))))))) + (if multibyte #'string #'unibyte-string) + (unless (equal byte-array '(:array :signature "y")) + (seq-filter #'characterp byte-array)))) (defun dbus-escape-as-identifier (string) "Escape an arbitrary STRING so it follows the rules for a C identifier. @@ -930,9 +912,9 @@ telepathy-glib's `tp_escape_as_identifier'." (if (zerop (length string)) "_" (replace-regexp-in-string - "^[0-9]\\|[^A-Za-z0-9]" + "\\`[0-9]\\|[^A-Za-z0-9]" (lambda (x) (format "_%2x" (aref x 0))) - string))) + string nil t))) (defun dbus-unescape-from-identifier (string) "Retrieve the original string from the encoded STRING as unibyte string. @@ -942,7 +924,7 @@ STRING must have been encoded with `dbus-escape-as-identifier'." (replace-regexp-in-string "_.." (lambda (x) (byte-to-string (string-to-number (substring x 1) 16))) - string))) + string nil t))) ;;; D-Bus events. @@ -1020,7 +1002,7 @@ If the HANDLER returns a `dbus-error', it is propagated as return message." (if (eq result :ignore) (dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event)) - (apply 'dbus-method-return-internal + (apply #'dbus-method-return-internal (nth 1 event) (nth 4 event) (nth 3 event) (if (consp result) result (list result))))))) ;; Error handling. @@ -1119,10 +1101,9 @@ unique names for services." (defun dbus-list-known-names (bus) "Retrieve all services which correspond to a known name in BUS. A service has a known name if it doesn't start with \":\"." - (let (result) - (dolist (name (dbus-list-names bus) (nreverse result)) - (unless (string-equal ":" (substring name 0 1)) - (push name result))))) + (seq-remove (lambda (name) + (= (string-to-char name) ?:)) + (dbus-list-names bus))) (defun dbus-list-queued-owners (bus service) "Return the unique names registered at D-Bus BUS and queued for SERVICE. @@ -1182,6 +1163,18 @@ It will be registered for all objects created by `dbus-register-service'." ;;; D-Bus introspection. +(defsubst dbus--introspect-names (object tag) + "Return the names of the children of OBJECT with TAG." + (mapcar (lambda (elt) + (dbus-introspect-get-attribute elt "name")) + (xml-get-children object tag))) + +(defsubst dbus--introspect-name (object tag name) + "Return the first child of OBJECT with TAG, whose name is NAME." + (seq-find (lambda (elt) + (string-equal (dbus-introspect-get-attribute elt "name") name)) + (xml-get-children object tag))) + (defun dbus-introspect (bus service path) "Return all interfaces and sub-nodes of SERVICE, registered at object path PATH at bus BUS. @@ -1197,17 +1190,25 @@ XML format." bus service path dbus-interface-introspectable "Introspect" :timeout 1000))) +(defalias 'dbus--parse-xml-buffer + (if (libxml-available-p) + (lambda () + (xml-remove-comments (point-min) (point-max)) + (libxml-parse-xml-region (point-min) (point-max))) + (lambda () + (car (xml-parse-region (point-min) (point-max))))) + "Compatibility shim for `libxml-parse-xml-region'.") + (defun dbus-introspect-xml (bus service path) "Return the introspection data of SERVICE in D-Bus BUS at object path PATH. The data are a parsed list. The root object is a \"node\", representing the object path PATH. The root object can contain \"interface\" and further \"node\" objects." - ;; We don't want to raise errors. - (xml-node-name - (ignore-errors - (with-temp-buffer - (insert (dbus-introspect bus service path)) - (xml-parse-region (point-min) (point-max)))))) + (with-temp-buffer + ;; We don't want to raise errors. + (ignore-errors + (insert (dbus-introspect bus service path)) + (dbus--parse-xml-buffer)))) (defun dbus-introspect-get-attribute (object attribute) "Return the ATTRIBUTE value of D-Bus introspection OBJECT. @@ -1219,21 +1220,15 @@ the D-Bus specification." "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings. The node names stand for further object paths of the D-Bus service." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'node) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'node)) (defun dbus-introspect-get-all-nodes (bus service path) "Return all node names of SERVICE in D-Bus BUS at object path PATH. It returns a list of strings, which are further object paths of SERVICE." - (let ((result (list path))) - (dolist (elt - (dbus-introspect-get-node-names bus service path) - result) - (setq elt (expand-file-name elt path)) - (setq result - (append result (dbus-introspect-get-all-nodes bus service elt)))))) + (cons path (mapcan (lambda (elt) + (setq elt (expand-file-name elt path)) + (dbus-introspect-get-all-nodes bus service elt)) + (dbus-introspect-get-node-names bus service path)))) (defun dbus-introspect-get-interface-names (bus service path) "Return all interface names of SERVICE in D-Bus BUS at object path PATH. @@ -1244,10 +1239,7 @@ always present. Another default interface is \"org.freedesktop.DBus.Properties\". If present, \"interface\" objects can also have \"property\" objects as children, beside \"method\" and \"signal\" objects." - (let ((object (dbus-introspect-xml bus service path)) - result) - (dolist (elt (xml-get-children object 'interface) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names (dbus-introspect-xml bus service path) 'interface)) (defun dbus-introspect-get-interface (bus service path interface) "Return the INTERFACE of SERVICE in D-Bus BUS at object path PATH. @@ -1256,22 +1248,14 @@ and a member of the list returned by `dbus-introspect-get-interface-names'. The resulting \"interface\" object can contain \"method\", \"signal\", \"property\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-xml bus service path) 'interface))) - (while (and elt - (not (string-equal - interface - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name (dbus-introspect-xml bus service path) + 'interface interface)) (defun dbus-introspect-get-method-names (bus service path interface) "Return a list of strings of all method names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'method) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'method)) (defun dbus-introspect-get-method (bus service path interface method) "Return method METHOD of interface INTERFACE as an XML object. @@ -1279,22 +1263,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. METHOD must be a string and a member of the list returned by `dbus-introspect-get-method-names'. The resulting \"method\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'method))) - (while (and elt - (not (string-equal - method (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'method method)) (defun dbus-introspect-get-signal-names (bus service path interface) "Return a list of strings of all signal names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'signal) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'signal)) (defun dbus-introspect-get-signal (bus service path interface signal) "Return signal SIGNAL of interface INTERFACE as an XML object. @@ -1302,22 +1279,15 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. SIGNAL must be a string, element of the list returned by `dbus-introspect-get-signal-names'. The resulting \"signal\" object can contain \"arg\" and \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'signal))) - (while (and elt - (not (string-equal - signal (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'signal signal)) (defun dbus-introspect-get-property-names (bus service path interface) "Return a list of strings of all property names of INTERFACE. SERVICE is a service of D-Bus BUS at object path PATH." - (let ((object (dbus-introspect-get-interface bus service path interface)) - result) - (dolist (elt (xml-get-children object 'property) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (dbus-introspect-get-interface bus service path interface) 'property)) (defun dbus-introspect-get-property (bus service path interface property) "Return PROPERTY of INTERFACE as an XML object. @@ -1325,15 +1295,9 @@ It must be located at SERVICE in D-Bus BUS at object path PATH. PROPERTY must be a string and a member of the list returned by `dbus-introspect-get-property-names'. The resulting PROPERTY object can contain \"annotation\" children." - (let ((elt (xml-get-children - (dbus-introspect-get-interface bus service path interface) - 'property))) - (while (and elt - (not (string-equal - property - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (dbus-introspect-get-interface bus service path interface) + 'property property)) (defun dbus-introspect-get-annotation-names (bus service path interface &optional name) @@ -1341,15 +1305,13 @@ object can contain \"annotation\" children." If NAME is nil, the annotations are children of INTERFACE, otherwise NAME must be a \"method\", \"signal\", or \"property\" object, where the annotations belong to." - (let ((object - (if name - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name) - (dbus-introspect-get-property bus service path interface name)) - (dbus-introspect-get-interface bus service path interface))) - result) - (dolist (elt (xml-get-children object 'annotation) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation)) (defun dbus-introspect-get-annotation (bus service path interface name annotation) @@ -1357,22 +1319,13 @@ object, where the annotations belong to." If NAME is nil, ANNOTATION is a child of INTERFACE, otherwise NAME must be the name of a \"method\", \"signal\", or \"property\" object, where the ANNOTATION belongs to." - (let ((elt (xml-get-children - (if name - (or (dbus-introspect-get-method - bus service path interface name) - (dbus-introspect-get-signal - bus service path interface name) - (dbus-introspect-get-property - bus service path interface name)) - (dbus-introspect-get-interface bus service path interface)) - 'annotation))) - (while (and elt - (not (string-equal - annotation - (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (if name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name) + (dbus-introspect-get-property bus service path interface name)) + (dbus-introspect-get-interface bus service path interface)) + 'annotation annotation)) (defun dbus-introspect-get-argument-names (bus service path interface name) "Return a list of all argument names as a list of strings. @@ -1380,27 +1333,20 @@ NAME must be a \"method\" or \"signal\" object. Argument names are optional, the function can return nil therefore, even if the method or signal has arguments." - (let ((object - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name))) - result) - (dolist (elt (xml-get-children object 'arg) (nreverse result)) - (push (dbus-introspect-get-attribute elt "name") result)))) + (dbus--introspect-names + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg)) (defun dbus-introspect-get-argument (bus service path interface name arg) "Return argument ARG as XML object. NAME must be a \"method\" or \"signal\" object. ARG must be a string and a member of the list returned by `dbus-introspect-get-argument-names'." - (let ((elt (xml-get-children - (or (dbus-introspect-get-method bus service path interface name) - (dbus-introspect-get-signal bus service path interface name)) - 'arg))) - (while (and elt - (not (string-equal - arg (dbus-introspect-get-attribute (car elt) "name")))) - (setq elt (cdr elt))) - (car elt))) + (dbus--introspect-name + (or (dbus-introspect-get-method bus service path interface name) + (dbus-introspect-get-signal bus service path interface name)) + 'arg arg)) (defun dbus-introspect-get-signature (bus service path interface name &optional direction) @@ -1469,13 +1415,10 @@ name of the property, and its value. If there are no properties, nil is returned." (dbus-ignore-errors ;; "GetAll" returns "a{sv}". - (let (result) - (dolist (dict - (dbus-call-method - bus service path dbus-interface-properties - "GetAll" :timeout 500 interface) - (nreverse result)) - (push (cons (car dict) (cl-caadr dict)) result))))) + (mapcar (lambda (dict) + (cons (car dict) (caadr dict))) + (dbus-call-method bus service path dbus-interface-properties + "GetAll" :timeout 500 interface)))) (defun dbus-register-property (bus service path interface property access value @@ -1520,13 +1463,13 @@ clients from discovering the still incomplete interface." ;; Add handlers for the three property-related methods. (dbus-register-method bus service path dbus-interface-properties "Get" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "GetAll" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) (dbus-register-method bus service path dbus-interface-properties "Set" - 'dbus-property-handler 'dont-register) + #'dbus-property-handler 'dont-register) ;; Register SERVICE. (unless (or dont-register-service (member service (dbus-list-names bus))) @@ -1673,7 +1616,7 @@ and \"org.freedesktop.DBus.Properties.GetAll\", which is slow." (if (cadr entry2) ;; "sv". (dolist (entry3 (cadr entry2)) - (setcdr entry3 (cl-caadr entry3))) + (setcdr entry3 (caadr entry3))) (setcdr entry2 nil))))) ;; Fallback: collect the information. Slooow! @@ -1730,7 +1673,7 @@ It will be registered for all objects created by `dbus-register-service'." (append (butlast last-input-event 4) (list object dbus-interface-properties - "GetAll" 'dbus-property-handler)))) + "GetAll" #'dbus-property-handler)))) (dbus-property-handler interface)))) (cdr (assoc object result))))))))) dbus-registered-objects-table) diff --git a/lisp/net/dig.el b/lisp/net/dig.el index 852d8ae0491..f36999119f2 100644 --- a/lisp/net/dig.el +++ b/lisp/net/dig.el @@ -1,4 +1,4 @@ -;;; dig.el --- Domain Name System dig interface +;;; dig.el --- Domain Name System dig interface -*- lexical-binding:t -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. @@ -42,15 +42,13 @@ (defcustom dig-program "dig" "Name of dig (domain information groper) binary." - :type 'file - :group 'dig) + :type 'file) (defcustom dig-dns-server nil "DNS server to query. If nil, use system defaults." :type '(choice (const :tag "System defaults") - string) - :group 'dig) + string)) (defcustom dig-font-lock-keywords '(("^;; [A-Z]+ SECTION:" 0 font-lock-keyword-face) @@ -58,8 +56,7 @@ If nil, use system defaults." ("^; <<>>.*" 0 font-lock-type-face) ("^;.*" 0 font-lock-function-name-face)) "Default expressions to highlight in dig mode." - :type 'sexp - :group 'dig) + :type 'sexp) (defun dig-invoke (domain &optional query-type query-class query-option diff --git a/lisp/net/dns.el b/lisp/net/dns.el index cefe0851f03..53ea0b19b52 100644 --- a/lisp/net/dns.el +++ b/lisp/net/dns.el @@ -138,7 +138,7 @@ updated. Set this variable to t to disable the check.") (defun dns-write (spec &optional tcp-p) "Write a DNS packet according to SPEC. -If TCP-P, the first two bytes of the package with be the length field." +If TCP-P, the first two bytes of the packet will be the length field." (with-temp-buffer (set-buffer-multibyte nil) (dns-write-bytes (dns-get 'id spec) 2) @@ -189,13 +189,15 @@ If TCP-P, the first two bytes of the package with be the length field." (dns-write-bytes (buffer-size) 2)) (buffer-string))) -(defun dns-read (packet) +(defun dns-read (packet &optional tcp-p) (with-temp-buffer (set-buffer-multibyte nil) (let ((spec nil) queries answers authorities additionals) (insert packet) - (goto-char (point-min)) + ;; When using TCP we have a 2 byte length field to ignore. + (goto-char (+ (point-min) + (if tcp-p 2 0))) (push (list 'id (dns-read-bytes 2)) spec) (let ((byte (dns-read-bytes 1))) (push (list 'response-p (if (zerop (logand byte (ash 1 7))) nil t)) @@ -258,10 +260,8 @@ If TCP-P, the first two bytes of the package with be the length field." (nreverse spec)))) (defun dns-read-int32 () - ;; Full 32 bit Integers can't be handled by 32-bit Emacsen. If we - ;; use floats, it works. - (format "%.0f" (+ (* (dns-read-bytes 1) 16777216.0) - (dns-read-bytes 3)))) + (declare (obsolete nil "28.1")) + (number-to-string (dns-read-bytes 4))) (defun dns-read-type (string type) (let ((buffer (current-buffer)) @@ -286,11 +286,11 @@ If TCP-P, the first two bytes of the package with be the length field." ((eq type 'SOA) (list (list 'mname (dns-read-name buffer)) (list 'rname (dns-read-name buffer)) - (list 'serial (dns-read-int32)) - (list 'refresh (dns-read-int32)) - (list 'retry (dns-read-int32)) - (list 'expire (dns-read-int32)) - (list 'minimum (dns-read-int32)))) + (list 'serial (dns-read-bytes 4)) + (list 'refresh (dns-read-bytes 4)) + (list 'retry (dns-read-bytes 4)) + (list 'expire (dns-read-bytes 4)) + (list 'minimum (dns-read-bytes 4)))) ((eq type 'SRV) (list (list 'priority (dns-read-bytes 2)) (list 'weight (dns-read-bytes 2)) @@ -317,8 +317,8 @@ If TCP-P, the first two bytes of the package with be the length field." (defun dns-set-servers () "Set `dns-servers' to a list of DNS servers or nil if none are found. Parses \"/etc/resolv.conf\" or calls \"nslookup\"." + (setq dns-servers nil) (or (when (file-exists-p "/etc/resolv.conf") - (setq dns-servers nil) (with-temp-buffer (insert-file-contents "/etc/resolv.conf") (goto-char (point-min)) @@ -329,9 +329,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." (with-temp-buffer (call-process "nslookup" nil t nil "localhost") (goto-char (point-min)) - (re-search-forward - "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\)" nil t) - (setq dns-servers (list (match-string 1)))))) + (when (re-search-forward + "^Address:[ \t]*\\([0-9]+\\.[0-9]+\\.[0-9]+\\.[0-9]+\\|[[:xdigit:]:]*\\)" nil t) + (setq dns-servers (list (match-string 1))))))) (when (fboundp 'network-interface-list) (setq dns-servers-valid-for-interfaces (network-interface-list)))) @@ -359,7 +359,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." `(let ((server ,server) (coding-system-for-read 'binary) (coding-system-for-write 'binary)) - (if (fboundp 'make-network-process) + (if (and + (fboundp 'make-network-process) + (featurep 'make-network-process '(:type datagram))) (make-network-process :name "dns" :coding 'binary @@ -367,9 +369,9 @@ Parses \"/etc/resolv.conf\" or calls \"nslookup\"." :host server :service "domain" :type 'datagram) - ;; Older versions of Emacs doesn't have - ;; `make-network-process', so we fall back on opening a TCP - ;; connection to the DNS server. + ;; Older versions of Emacs do not have `make-network-process', + ;; and on MS-Windows datagram sockets are not supported, so we + ;; fall back on opening a TCP connection to the DNS server. (open-network-stream "dns" (current-buffer) server "domain")))) (defvar dns-cache (make-vector 4096 0)) @@ -402,26 +404,30 @@ If REVERSEP, look up an IP address." type 'PTR)) (if (not dns-servers) - (message "No DNS server configuration found") + (progn + (message "No DNS server configuration found") + nil) (with-temp-buffer (set-buffer-multibyte nil) - (let ((process (condition-case () - (dns-make-network-process (car dns-servers)) - (error - (message - "dns: Got an error while trying to talk to %s" - (car dns-servers)) - nil))) + (let* ((process (condition-case () + (dns-make-network-process (car dns-servers)) + (error + (message + "dns: Got an error while trying to talk to %s" + (car dns-servers)) + nil))) (step 100) (times (* dns-timeout 1000)) - (id (random 65000))) + (id (random 65000)) + (tcp-p (and process (not (process-contact process :type))))) (when process (process-send-string process (dns-write `((id ,id) (opcode query) (queries ((,name (type ,type)))) - (recursion-desired-p t)))) + (recursion-desired-p t)) + tcp-p)) (while (and (zerop (buffer-size)) (> times 0)) (let ((step-sec (/ step 1000.0))) @@ -434,7 +440,7 @@ If REVERSEP, look up an IP address." (when (and (>= (buffer-size) 2) ;; We had a time-out. (> times 0)) - (let ((result (dns-read (buffer-string)))) + (let ((result (dns-read (buffer-string) tcp-p))) (if fullp result (let ((answer (car (dns-get 'answers result)))) diff --git a/lisp/net/eudcb-macos-contacts.el b/lisp/net/eudcb-macos-contacts.el new file mode 100644 index 00000000000..f258d5cb9fb --- /dev/null +++ b/lisp/net/eudcb-macos-contacts.el @@ -0,0 +1,118 @@ +;;; eudcb-macos-contacts.el --- EUDC - macOS Contacts backend + +;; Copyright (C) 2020 condition-alpha.com + +;; This program is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. +;; +;; This program is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. +;; +;; You should have received a copy of the GNU General Public License +;; along with this program. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; This library provides an interface to the macOS Contacts app as +;; an EUDC data source. It uses AppleScript to interface with the +;; Contacts app on localhost, so no 3rd party tools are needed. + +;;; Usage: +;; (require 'eudcb-macos-contacts) +;; (eudc-macos-contacts-set-server "localhost") + +;;; Code: + +(require 'eudc) +(require 'executable) + +;;{{{ Internal cooking + +(defvar eudc-macos-contacts-conversion-alist nil) + +;; hook ourselves into the EUDC framework +(eudc-protocol-set 'eudc-query-function + 'eudc-macos-contacts-query-internal + 'macos-contacts) +(eudc-protocol-set 'eudc-list-attributes-function + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-macos-contacts-conversion-alist + nil + 'macos-contacts) +(eudc-protocol-set 'eudc-protocol-has-default-query-attributes + nil + 'macos-contacts) + +(defun eudc-macos-contacts-search-helper (str) + "Helper function to query the Contacts app via AppleScript. +Searches for all persons with a case-insensitive substring match +of STR in any of their name fields (first, middle, or last)." + (if (executable-find "osascript") + (call-process "osascript" nil t nil + "-e" + (format " +set results to {} +tell application \"Address Book\" + set pList to every person whose (name contains \"%s\") + repeat with pers in pList + repeat with emailAddr in emails of pers + set results to results & {name of pers & \":\" & value ¬ + of emailAddr & \"\n\"} + end repeat + end repeat + get results as text +end tell" str)) + (message (concat "[eudc] Error in macOS Contacts backend: " + "`osascript' executable not found. " + "Is this is a macOS 10.0 or later system?")))) + +(defun eudc-macos-contacts-query-internal (query &optional return-attrs) + "Query macOS Contacts with QUERY. +QUERY is a list of cons cells (ATTR . VALUE) where ATTRs should be valid +macOS Contacts attribute names. +RETURN-ATTRS is a list of attributes to return, defaulting to +`eudc-default-return-attributes'." + (let ((macos-contacts-buffer (get-buffer-create " *macOS Contacts*")) + result) + (with-current-buffer macos-contacts-buffer + (erase-buffer) + (dolist (term query) + (eudc-macos-contacts-search-helper (cdr term))) + (delete-duplicate-lines (point-min) (point-max)) + (goto-char (point-min)) + (while (not (eobp)) + (if (not (equal (line-beginning-position) (line-end-position))) + (let* ((args (split-string (buffer-substring + (point) (line-end-position)) + ":")) + (name (nth 0 args)) + (email (nth 1 args))) + (setq result (cons `((name . ,name) + (email . ,email)) result)))) + (forward-line)) + result))) + +;;}}} + +;;{{{ High-level interfaces (interactive functions) + +(defun eudc-macos-contacts-set-server (dummy) + "Set the EUDC server to macOS Contacts app. +The server in DUMMY is not actually used, since this backend +always and implicitly connetcs to an instance of the Contacts app +running on the local host." + (interactive) + (eudc-set-server dummy 'macos-contacts) + (message "[eudc] macOS Contacts app server selected")) + +;;}}} + +(eudc-register-protocol 'macos-contacts) + +(provide 'eudcb-macos-contacts) + +;;; eudcb-macos-contacts.el ends here diff --git a/lisp/net/eww.el b/lisp/net/eww.el index 568b96f4d58..edb2f729c8b 100644 --- a/lisp/net/eww.el +++ b/lisp/net/eww.el @@ -25,14 +25,15 @@ ;;; Code: (require 'cl-lib) -(require 'format-spec) +(require 'mm-url) +(require 'puny) (require 'shr) +(require 'text-property-search) +(require 'thingatpt) (require 'url) (require 'url-queue) -(require 'thingatpt) -(require 'mm-url) -(require 'puny) -(eval-when-compile (require 'subr-x)) ;; for string-trim +(require 'xdg) +(eval-when-compile (require 'subr-x)) (defgroup eww nil "Emacs Web Wowser" @@ -55,11 +56,24 @@ :group 'eww :type 'string) -(defcustom eww-download-directory "~/Downloads/" - "Directory where files will downloaded." - :version "24.4" +(defun erc--download-directory () + "Return the name of the download directory. +If ~/Downloads/ exists, that will be used, and if not, the +DOWNLOAD XDG user directory will be returned. If that's +undefined, ~/Downloads/ is returned anyway." + (or (and (file-exists-p "~/Downloads/") + "~/Downloads/") + (when-let ((dir (xdg-user-dir "DOWNLOAD"))) + (file-name-as-directory dir)) + "~/Downloads/")) + +(defcustom eww-download-directory 'erc--download-directory + "Directory where files will downloaded. +This should either be a directory name or a function (called with +no parameters) that returns a directory name." + :version "28.1" :group 'eww - :type 'directory) + :type '(choice directory function)) ;;;###autoload (defcustom eww-suggest-uris @@ -263,13 +277,17 @@ This list can be customized via `eww-suggest-uris'." (nreverse uris))) ;;;###autoload -(defun eww (url &optional arg) +(defun eww (url &optional arg buffer) "Fetch URL and render the page. If the input doesn't look like an URL or a domain name, the word(s) will be searched for via `eww-search-prefix'. If called with a prefix ARG, use a new buffer instead of reusing -the default EWW buffer." +the default EWW buffer. + +If BUFFER, the data to be rendered is in that buffer. In that +case, this function doesn't actually fetch URL. BUFFER will be +killed after rendering." (interactive (let* ((uris (eww-suggested-uris)) (prompt (concat "Enter URL or keywords" @@ -307,8 +325,14 @@ the default EWW buffer." (insert (format "Loading %s..." url)) (goto-char (point-min))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render - (list url nil (current-buffer))))) + (if buffer + (let ((eww-buffer (current-buffer))) + (with-current-buffer buffer + (eww-render nil url nil eww-buffer))) + (url-retrieve url #'eww-render + (list url nil (current-buffer)))))) + +(function-put 'eww 'browse-url-browser-kind 'internal) (defun eww--dwim-expand-url (url) (setq url (string-trim url)) @@ -359,7 +383,19 @@ the default EWW buffer." (eww (concat "file://" (and (memq system-type '(windows-nt ms-dos)) "/") - (expand-file-name file)))) + (expand-file-name file)) + nil + ;; The file name may be a non-local Tramp file. The URL + ;; library doesn't understand these file names, so use the + ;; normal Emacs machinery to load the file. + (with-current-buffer (generate-new-buffer " *eww file*") + (set-buffer-multibyte nil) + (insert "Content-type: " (or (mailcap-extension-to-mime + (url-file-extension file)) + "application/octet-stream") + "\n\n") + (insert-file-contents file) + (current-buffer)))) ;;;###autoload (defun eww-search-words () @@ -373,8 +409,8 @@ engine used." (let ((region-string (buffer-substring (region-beginning) (region-end)))) (if (not (string-match-p "\\`[ \n\t\r\v\f]*\\'" region-string)) (eww region-string) - (call-interactively 'eww))) - (call-interactively 'eww))) + (call-interactively #'eww))) + (call-interactively #'eww))) (defun eww-open-in-new-buffer () "Fetch link at point in a new EWW buffer." @@ -541,10 +577,10 @@ Currently this means either text/html or application/xhtml+xml." (goto-char point)) (shr-target-id (goto-char (point-min)) - (let ((point (next-single-property-change - (point-min) 'shr-target-id))) - (when point - (goto-char point)))) + (let ((match (text-property-search-forward + 'shr-target-id shr-target-id t))) + (when match + (goto-char (prop-match-beginning match))))) (t (goto-char (point-min)) ;; Don't leave point inside forms, because the normal eww @@ -1011,7 +1047,7 @@ just re-display the HTML already fetched." (eww-display-html 'utf-8 url (plist-get eww-data :dom) (point) (current-buffer))) (let ((url-mime-accept-string eww-accept-content-types)) - (url-retrieve url 'eww-render + (url-retrieve url #'eww-render (list url (point) (current-buffer) encode)))))) ;; Form support. @@ -1111,11 +1147,13 @@ just re-display the HTML already fetched." (defun eww-form-submit (dom) (let ((start (point)) (value (dom-attr dom 'value))) - (setq value - (if (zerop (length value)) - "Submit" - value)) - (insert value) + (if (null value) + (shr-generic dom) + (insert value)) + ;; If the contents of the <button>...</button> turns out to be + ;; empty, or the value was blank, default to this: + (when (= (point) start) + (insert "Submit")) (add-face-text-property start (point) 'eww-form-submit) (put-text-property start (point) 'eww-form (list :eww-form eww-form @@ -1256,7 +1294,7 @@ See URL `https://developer.mozilla.org/en-US/docs/Web/HTML/Element/Input'.") (defun eww-tag-textarea (dom) (let ((start (point)) - (value (or (dom-attr dom 'value) "")) + (value (or (dom-text dom) "")) (lines (string-to-number (or (dom-attr dom 'rows) "10"))) (width (string-to-number (or (dom-attr dom 'cols) "10"))) end) @@ -1572,8 +1610,10 @@ If EXTERNAL is double prefix, browse in new buffer." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + ((string-match-p "\\`mailto:" url) + ;; This respects the user options `browse-url-handlers' + ;; and `browse-url-mailto-function'. + (browse-url url)) ((and (consp external) (<= (car external) 4)) (funcall browse-url-secondary-browser-function url) (shr--blink-link)) @@ -1606,20 +1646,23 @@ Differences in #targets are ignored." "Download URL to `eww-download-directory'. Use link at point if there is one, else the current page's URL." (interactive) - (access-file eww-download-directory "Download failed") - (let ((url (or (get-text-property (point) 'shr-url) - (eww-current-url)))) - (if (not url) - (message "No URL under point") - (url-retrieve url 'eww-download-callback (list url))))) - -(defun eww-download-callback (status url) + (let ((dir (if (stringp eww-download-directory) + eww-download-directory + (funcall eww-download-directory)))) + (access-file dir "Download failed") + (let ((url (or (get-text-property (point) 'shr-url) + (eww-current-url)))) + (if (not url) + (message "No URL under point") + (url-retrieve url #'eww-download-callback (list url dir)))))) + +(defun eww-download-callback (status url dir) (unless (plist-get status :error) (let* ((obj (url-generic-parse-url url)) (path (directory-file-name (car (url-path-and-query obj)))) (file (eww-make-unique-file-name (eww-decode-url-file-name (file-name-nondirectory path)) - eww-download-directory))) + dir))) (goto-char (point-min)) (re-search-forward "\r?\n\r?\n") (let ((coding-system-for-write 'no-conversion)) @@ -1735,28 +1778,30 @@ If CHARSET is nil then use UTF-8." (defun eww-write-bookmarks () (with-temp-file (expand-file-name "eww-bookmarks" eww-bookmarks-directory) - (insert ";; Auto-generated file; don't edit\n") + (insert ";; Auto-generated file; don't edit -*- mode: lisp-data -*-\n") (pp eww-bookmarks (current-buffer)))) -(defun eww-read-bookmarks () +(defun eww-read-bookmarks (&optional error-out) + "Read bookmarks from `eww-bookmarks'. +If ERROR-OUT, signal user-error if there are no bookmarks." (let ((file (expand-file-name "eww-bookmarks" eww-bookmarks-directory))) (setq eww-bookmarks (unless (zerop (or (file-attribute-size (file-attributes file)) 0)) (with-temp-buffer (insert-file-contents file) - (read (current-buffer))))))) + (read (current-buffer))))) + (when (and error-out (not eww-bookmarks)) + (user-error "No bookmarks are defined")))) ;;;###autoload (defun eww-list-bookmarks () "Display the bookmarks." (interactive) + (eww-read-bookmarks t) (pop-to-buffer "*eww bookmarks*") (eww-bookmark-prepare)) (defun eww-bookmark-prepare () - (eww-read-bookmarks) - (unless eww-bookmarks - (user-error "No bookmarks are defined")) (set-buffer (get-buffer-create "*eww bookmarks*")) (eww-bookmark-mode) (let* ((width (/ (window-width) 2)) @@ -1824,6 +1869,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (when (and (not first) @@ -1842,6 +1888,7 @@ If CHARSET is nil then use UTF-8." bookmark) (unless (get-buffer "*eww bookmarks*") (setq first t) + (eww-read-bookmarks t) (eww-bookmark-prepare)) (with-current-buffer (get-buffer "*eww bookmarks*") (if first @@ -2124,12 +2171,12 @@ entries (if any) will be removed from the list. Only the properties listed in `eww-desktop-data-save' are included. Generally, the list should not include the (usually overly large) :dom, :source and :text properties." - (let ((history (mapcar 'eww-desktop-data-1 - (cons eww-data eww-history)))) - (list :history (if eww-desktop-remove-duplicates - (cl-remove-duplicates - history :test 'eww-desktop-history-duplicate) - history)))) + (let ((history (mapcar #'eww-desktop-data-1 + (cons eww-data eww-history)))) + (list :history (if eww-desktop-remove-duplicates + (cl-remove-duplicates + history :test #'eww-desktop-history-duplicate) + history)))) (defun eww-restore-desktop (file-name buffer-name misc-data) "Restore an eww buffer from its desktop file record. diff --git a/lisp/net/gnutls.el b/lisp/net/gnutls.el index 5212bf6a3f6..e713c94117b 100644 --- a/lisp/net/gnutls.el +++ b/lisp/net/gnutls.el @@ -170,8 +170,9 @@ Third arg HOST is the name of the host to connect to, or its IP address. Fourth arg SERVICE is the name of the service desired, or an integer specifying a port number to connect to. Fifth arg PARAMETERS is an optional list of keyword/value pairs. -Only :client-certificate and :nowait keywords are recognized, and -have the same meaning as for `open-network-stream'. +Only :client-certificate, :nowait, and :coding keywords are +recognized, and have the same meaning as for +`open-network-stream'. For historical reasons PARAMETERS can also be a symbol, which is interpreted the same as passing a list containing :nowait and the value of that symbol. @@ -209,7 +210,8 @@ trust and key files, and priority string." (gnutls-boot-parameters :type 'gnutls-x509pki :keylist keylist - :hostname (puny-encode-domain host))))))) + :hostname (puny-encode-domain host)))) + :coding (plist-get parameters :coding)))) (if nowait process (gnutls-negotiate :process process diff --git a/lisp/net/hmac-md5.el b/lisp/net/hmac-md5.el index 92efb6ba275..974ee0d3691 100644 --- a/lisp/net/hmac-md5.el +++ b/lisp/net/hmac-md5.el @@ -1,4 +1,4 @@ -;;; hmac-md5.el --- Compute HMAC-MD5. +;;; hmac-md5.el --- Compute HMAC-MD5. -*- lexical-binding:t -*- ;; Copyright (C) 1999, 2001, 2007-2020 Free Software Foundation, Inc. @@ -22,42 +22,8 @@ ;;; Commentary: -;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1". -;; -;; (encode-hex-string (hmac-md5 "Hi There" (make-string 16 ?\x0b))) -;; => "9294727a3638bb1c13f48ef8158bfc9d" -;; -;; (encode-hex-string (hmac-md5 "what do ya want for nothing?" "Jefe")) -;; => "750c783e6ab0b503eaa86e310a5db738" -;; -;; (encode-hex-string (hmac-md5 (make-string 50 ?\xdd) (make-string 16 ?\xaa))) -;; => "56be34521d144c88dbb8c733f0e8b3f6" -;; -;; (encode-hex-string -;; (hmac-md5 -;; (make-string 50 ?\xcd) -;; (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) -;; => "697eaf0aca3a3aea3a75164746ffaa79" -;; -;; (encode-hex-string -;; (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995690efd4c" -;; -;; (encode-hex-string -;; (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) -;; => "56461ef2342edc00f9bab995" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key - Hash Key First" -;; (make-string 80 ?\xaa))) -;; => "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd" -;; -;; (encode-hex-string -;; (hmac-md5 -;; "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" -;; (make-string 80 ?\xaa))) -;; => "6f630fad67cda0ee1fb1f562db3aa53e" +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved to lisp/test/net/hmac-md5-tests.el ;;; Code: diff --git a/lisp/net/imap.el b/lisp/net/imap.el index aa10f0291fd..a492dc8c798 100644 --- a/lisp/net/imap.el +++ b/lisp/net/imap.el @@ -136,7 +136,6 @@ ;;; Code: (eval-when-compile (require 'cl-lib)) -(require 'format-spec) (require 'utf7) (require 'rfc2104) ;; Hmm... digest-md5 is not part of Emacs. @@ -517,12 +516,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -583,12 +579,9 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?p (number-to-string port) - ?l imap-default-user)))) + (format-spec cmd `((?s . ,server) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user))))) response) (when process (with-current-buffer buffer @@ -701,13 +694,10 @@ sure of changing the value of `foo'." (process-connection-type imap-process-connection-type) (process (start-process name buffer shell-file-name shell-command-switch - (format-spec - cmd - (format-spec-make - ?s server - ?g imap-shell-host - ?p (number-to-string port) - ?l imap-default-user))))) + (format-spec cmd `((?s . ,server) + (?g . ,imap-shell-host) + (?p . ,(number-to-string port)) + (?l . ,imap-default-user)))))) (when process (while (and (memq (process-status process) '(open run)) (set-buffer buffer) ;; XXX "blue moon" nntp.el bug diff --git a/lisp/net/ldap.el b/lisp/net/ldap.el index e42a7655ef3..700653250fb 100644 --- a/lisp/net/ldap.el +++ b/lisp/net/ldap.el @@ -727,7 +727,7 @@ an alist of attribute/value pairs." (setq record nil) (skip-chars-forward " \t\n") (message "Parsing results... %d" numres) - (1+ numres)) + (setq numres (1+ numres))) (message "Parsing results... done") (nreverse result))))) diff --git a/lisp/net/network-stream.el b/lisp/net/network-stream.el index e99d7a372c0..e86426d4664 100644 --- a/lisp/net/network-stream.el +++ b/lisp/net/network-stream.el @@ -113,6 +113,10 @@ values: `ssl' -- Equivalent to `tls'. `shell' -- A shell connection. +:coding is a symbol or a cons used to specify the coding systems +used to decode and encode the data which the process reads and +writes. See `make-network-process' for details. + :return-list specifies this function's return value. If omitted or nil, return a process object. A non-nil means to return (PROC . PROPS), where PROC is a process object and PROPS @@ -135,7 +139,10 @@ values: :capability-command specifies a command used to query the HOST for its capabilities. For instance, for IMAP this should be - \"1 CAPABILITY\\r\\n\". + \"1 CAPABILITY\\r\\n\". This can either be a string (which will + then be sent verbatim to the server), or a function (called with + a single parameter; the \"greeting\" from the server when connecting), + and should return a string to send to the server. :starttls-function specifies a function for handling STARTTLS. This function should take one parameter, the response to the @@ -166,8 +173,8 @@ a greeting from the server. :nowait, if non-nil, says the connection should be made asynchronously, if possible. -:shell-command is a format-spec string that can be used if :type -is `shell'. It has two specs, %s for host and %p for port +:shell-command is a `format-spec' string that can be used if +:type is `shell'. It has two specs, %s for host and %p for port number. Example: \"ssh gateway nc %s %p\". :tls-parameters is a list that should be supplied if you're @@ -189,7 +196,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." :host (puny-encode-domain host) :service service :nowait (plist-get parameters :nowait) :tls-parameters - (plist-get parameters :tls-parameters)) + (plist-get parameters :tls-parameters) + :coding (plist-get parameters :coding)) (let ((work-buffer (or buffer (generate-new-buffer " *stream buffer*"))) (fun (cond ((and (eq type 'plain) @@ -249,7 +257,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) :service service - :nowait (plist-get parameters :nowait)))) + :nowait (plist-get parameters :nowait) + :coding (plist-get parameters :coding)))) (when (plist-get parameters :warn-unless-encrypted) (setq stream (nsm-verify-connection stream host service nil t))) (list stream @@ -270,11 +279,15 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Return (STREAM GREETING CAPABILITIES RESULTING-TYPE) (stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (greeting (and (not (plist-get parameters :nogreeting)) (network-stream-get-response stream start eoc))) - (capabilities (network-stream-command stream capability-command - eo-capa)) + (capabilities + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)) (resulting-type 'plain) starttls-available starttls-command error) @@ -322,7 +335,10 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; Requery capabilities for protocols that require it; i.e., ;; EHLO for SMTP. (when (plist-get parameters :always-query-capabilities) - (network-stream-command stream capability-command eo-capa))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa))) (when (let ((response (network-stream-command stream starttls-command eoc))) (and response (string-match success-string response))) @@ -350,14 +366,18 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." (setq stream (make-network-process :name name :buffer buffer :host (puny-encode-domain host) - :service service)) + :service service + :coding (plist-get parameters :coding))) (network-stream-get-response stream start eoc))) (unless (process-live-p stream) (error "Unable to negotiate a TLS connection with %s/%s" host service)) ;; Re-get the capabilities, which may have now changed. (setq capabilities - (network-stream-command stream capability-command eo-capa)))) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + eo-capa)))) ;; If TLS is mandatory, close the connection if it's unencrypted. (when (and require-tls @@ -420,7 +440,8 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." parameters) (require 'tls) (open-tls-stream name buffer host service))) - (eoc (plist-get parameters :end-of-command))) + (eoc (plist-get parameters :end-of-command)) + greeting) (if (plist-get parameters :nowait) (list stream nil nil 'tls) ;; Check certificate validity etc. @@ -432,42 +453,58 @@ gnutls-boot (as returned by `gnutls-boot-parameters')." ;; openssl/gnutls-cli. (when (and (not (gnutls-available-p)) eoc) - (network-stream-get-response stream start eoc) + (setq greeting (network-stream-get-response stream start eoc)) (goto-char (point-min)) (when (re-search-forward eoc nil t) (goto-char (match-beginning 0)) (delete-region (point-min) (line-beginning-position)))) - (let ((capability-command (plist-get parameters :capability-command)) + (let ((capability-command + (plist-get parameters :capability-command)) (eo-capa (or (plist-get parameters :end-of-capability) eoc))) (list stream (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command eo-capa) + (network-stream-command + stream + (network-stream--capability-command + capability-command greeting) + eo-capa) 'tls))))))) -(declare-function format-spec "format-spec" (format spec)) -(declare-function format-spec-make "format-spec" (&rest pairs)) - (defun network-stream-open-shell (name buffer host service parameters) - (require 'format-spec) (let* ((capability-command (plist-get parameters :capability-command)) (eoc (plist-get parameters :end-of-command)) (start (with-current-buffer buffer (point))) + (coding (plist-get parameters :coding)) (stream (let ((process-connection-type nil)) (start-process name buffer shell-file-name shell-command-switch (format-spec (plist-get parameters :shell-command) - (format-spec-make - ?s host - ?p service)))))) + `((?s . ,host) + (?p . ,service)))))) + greeting) + (when coding (if (consp coding) + (set-process-coding-system stream + (car coding) + (cdr coding)) + (set-process-coding-system stream + coding + coding))) (list stream - (network-stream-get-response stream start eoc) - (network-stream-command stream capability-command - (or (plist-get parameters :end-of-capability) - eoc)) + (setq greeting (network-stream-get-response stream start eoc)) + (network-stream-command + stream + (network-stream--capability-command capability-command greeting) + (or (plist-get parameters :end-of-capability) + eoc)) 'plain))) +(defun network-stream--capability-command (command greeting) + (if (functionp command) + (funcall command greeting) + command)) + (provide 'network-stream) ;;; network-stream.el ends here diff --git a/lisp/net/newst-backend.el b/lisp/net/newst-backend.el index eb61d7a6796..b8f1bccd788 100644 --- a/lisp/net/newst-backend.el +++ b/lisp/net/newst-backend.el @@ -363,7 +363,7 @@ description are marked as immortal." (const :tag "Title" title) (const :tag "Description" description) (const :tag "All" all)) - (string :tag "Regexp"))))) + (regexp :tag "Regexp"))))) :group 'newsticker-headline-processing) ;; ====================================================================== diff --git a/lisp/net/nsm.el b/lisp/net/nsm.el index e94947bc7f1..cc22427e6d1 100644 --- a/lisp/net/nsm.el +++ b/lisp/net/nsm.el @@ -311,9 +311,9 @@ See also: `network-security-protocol-checks' and `nsm-noninteractive'" (map-values results) "\n") "\n") - "\n* "))))) - (delete-process process) - (setq process nil))) + "\n* ")))))) + (delete-process process) + (setq process nil)) (run-hook-with-args 'nsm-tls-post-check-functions host port status settings results))) process) @@ -371,7 +371,7 @@ Reference: Sheffer, Holz, Saint-Andre (May 2015). \"Recommendations for Secure Use of Transport Layer Security (TLS) and Datagram Transport Layer Security (DTLS)\", \"(4.1. General Guidelines)\" -`https://tools.ietf.org/html/rfc7525\#section-4.1'" +`https://tools.ietf.org/html/rfc7525#section-4.1'" (let ((kx (plist-get status :key-exchange))) (and (string-match "^\\bRSA\\b" kx) (format-message @@ -468,7 +468,7 @@ Reference: GnuTLS authors (2018). \"GnuTLS Manual 4.3.3 Anonymous authentication\", -`https://www.gnutls.org/manual/gnutls.html\#Anonymous-authentication'" +`https://www.gnutls.org/manual/gnutls.html#Anonymous-authentication'" (let ((kx (plist-get status :key-exchange))) (and (string-match "\\bANON\\b" kx) (format-message @@ -603,7 +603,7 @@ References: full SHA-1\", `https://shattered.io/static/shattered.pdf' [2]: Chromium Security Education TLS/SSL. \"Deprecated and Removed Features (SHA-1 Certificate Signatures)\", -`https://www.chromium.org/Home/chromium-security/education/tls\#TOC-SHA-1-Certificate-Signatures' +`https://www.chromium.org/Home/chromium-security/education/tls#TOC-SHA-1-Certificate-Signatures' [3]: Jones J.C (2017). \"The end of SHA-1 on the Public Web\", `https://blog.mozilla.org/security/2017/02/23/the-end-of-sha-1-on-the-public-web/' [4]: Apple Support (2017). \"Move to SHA-256 signed certificates to @@ -964,6 +964,7 @@ protocol." (defun nsm-write-settings () (with-temp-file nsm-settings-file + (insert ";;;; -*- mode: lisp-data -*-\n") (insert "(\n") (dolist (setting nsm-permanent-host-settings) (insert " ") diff --git a/lisp/net/puny.el b/lisp/net/puny.el index 60a6c12e6c7..cc406076c58 100644 --- a/lisp/net/puny.el +++ b/lisp/net/puny.el @@ -1,4 +1,4 @@ -;;; puny.el --- translate non-ASCII domain names to ASCII +;;; puny.el --- translate non-ASCII domain names to ASCII -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -35,7 +35,7 @@ For instance, \"fśf.org\" => \"xn--ff-2sa.org\"." ;; The vast majority of domain names are not IDNA domain names, so ;; add a check first to avoid doing unnecessary work. - (if (string-match "\\'[[:ascii:]]+\\'" domain) + (if (string-match "\\`[[:ascii:]]+\\'" domain) domain (mapconcat 'puny-encode-string (split-string domain "[.]") "."))) diff --git a/lisp/net/rcirc.el b/lisp/net/rcirc.el index fff640bb675..1766e192f2d 100644 --- a/lisp/net/rcirc.el +++ b/lisp/net/rcirc.el @@ -254,7 +254,7 @@ Examples: (\"bitlbee\" bitlbee \"robert\" \"sekrit\") (\"dal.net\" nickserv \"bob\" \"sekrit\" \"NickServ@services.dal.net\") (\"quakenet.org\" quakenet \"bobby\" \"sekrit\"))" - :type '(alist :key-type (string :tag "Server") + :type '(alist :key-type (regexp :tag "Server") :value-type (choice (list :tag "NickServ" (const nickserv) (string :tag "Nick") @@ -359,9 +359,9 @@ If VAL is a coding system, it is used for both decoding and encoding messages. If VAL is a cons of coding systems, the car part is used for decoding, and the cdr part is used for encoding." - :type '(alist :key-type (choice (string :tag "Channel Regexp") - (cons (string :tag "Channel Regexp") - (string :tag "Server Regexp"))) + :type '(alist :key-type (choice (regexp :tag "Channel Regexp") + (cons (regexp :tag "Channel Regexp") + (regexp :tag "Server Regexp"))) :value-type (choice coding-system (cons (coding-system :tag "Decode") (coding-system :tag "Encode"))))) @@ -2421,7 +2421,7 @@ keywords when no KEYWORD is given." (concat "\\(?:" ;; Match paired parentheses, e.g. in Wikipedia URLs: - "[" chars punct "]+" "(" "[" chars punct "]+" "[" chars "]*)" "[" chars "]" + "[" chars punct "]+" "(" "[" chars punct "]+" ")" "[" chars "]" "\\|" "[" chars punct "]+" "[" chars "]" "\\)")) @@ -2626,12 +2626,16 @@ the only argument." (and ;; nickserv (string= sender "NickServ") (string= target rcirc-nick) - (member message - (list - (format "You are now identified for \C-b%s\C-b." rcirc-nick) - (format "You are successfully identified as \C-b%s\C-b." rcirc-nick) - "Password accepted - you are now recognized." - ))) + (cl-member + message + (list + (format "You are now identified for \C-b%s\C-b." rcirc-nick) + (format "You are successfully identified as \C-b%s\C-b." + rcirc-nick) + "Password accepted - you are now recognized.") + ;; The nick may have a different case, so match + ;; case-insensitively (Bug#39345). + :test #'cl-equalp)) (and ;; quakenet (string= sender "Q") (string= target rcirc-nick) diff --git a/lisp/net/sasl-scram-sha256.el b/lisp/net/sasl-scram-sha256.el new file mode 100644 index 00000000000..e50a032c233 --- /dev/null +++ b/lisp/net/sasl-scram-sha256.el @@ -0,0 +1,59 @@ +;;; sasl-scram-sha256.el --- SCRAM-SHA-256 module for the SASL client framework -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simon Josefsson <simon@josefsson.org> +;; Package: sasl + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Implement the SCRAM-SHA-256 mechanism from RFC 7677. + +;;; Code: + +(require 'cl-lib) +(require 'sasl) +(require 'hex-util) +(require 'rfc2104) +(require 'sasl-scram-rfc) + +;;; SCRAM-SHA-256 + +(defconst sasl-scram-sha-256-steps + '(sasl-scram-client-first-message + sasl-scram-sha-256-client-final-message + sasl-scram-sha-256-authenticate-server)) + +(defun sasl-scram-sha256 (object &optional start end binary) + (secure-hash 'sha256 object start end binary)) + +(defun sasl-scram-sha-256-client-final-message (client step) + (sasl-scram--client-final-message + ;; HMAC-SHA256 uses block length 64 and hash length 32; see RFC 4634. + 'sasl-scram-sha256 64 32 client step)) + +(defun sasl-scram-sha-256-authenticate-server (client step) + (sasl-scram--authenticate-server + 'sasl-scram-sha256 64 32 client step)) + +(put 'sasl-scram-sha256 'sasl-mechanism + (sasl-make-mechanism "SCRAM-SHA-256" sasl-scram-sha-256-steps)) + +(provide 'sasl-scram-sha256) + +;;; sasl-scram-sha256.el ends here diff --git a/lisp/net/sasl.el b/lisp/net/sasl.el index 4405c904cd3..ab118e1f982 100644 --- a/lisp/net/sasl.el +++ b/lisp/net/sasl.el @@ -35,8 +35,8 @@ ;;; Code: (defvar sasl-mechanisms - '("SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" "ANONYMOUS" - "NTLM")) + '("SCRAM-SHA-256" "SCRAM-SHA-1" "CRAM-MD5" "DIGEST-MD5" "PLAIN" "LOGIN" + "ANONYMOUS" "NTLM")) (defvar sasl-mechanism-alist '(("CRAM-MD5" sasl-cram) @@ -45,6 +45,7 @@ ("LOGIN" sasl-login) ("ANONYMOUS" sasl-anonymous) ("NTLM" sasl-ntlm) + ("SCRAM-SHA-256" sasl-scram-sha256) ("SCRAM-SHA-1" sasl-scram-rfc))) (defvar sasl-unique-id-function #'sasl-unique-id-function) diff --git a/lisp/net/shr.el b/lisp/net/shr.el index 241180d471a..ddd81127213 100644 --- a/lisp/net/shr.el +++ b/lisp/net/shr.el @@ -95,15 +95,31 @@ If nil, don't draw horizontal table lines." :type 'character) (defcustom shr-width nil - "Frame width to use for rendering. + "Window width to use for HTML rendering. May either be an integer specifying a fixed width in characters, -or nil, meaning that the full width of the window should be used. -If `shr-use-fonts' is set, the mean character width is used to -compute the pixel width, which is used instead." +or nil, meaning use the full width of the window. +If `shr-use-fonts' is set, the value is interpreted as a multiple +of the mean character width of the default face's font. + +Also see `shr-max-width'." :version "25.1" :type '(choice (integer :tag "Fixed width in characters") (const :tag "Use the width of the window" nil))) +(defcustom shr-max-width 120 + "Maximum text width to use for HTML rendering. +May either be an integer specifying a fixed width in characters, +or nil, meaning that there is no width limit. + +If `shr-use-fonts' is set, the value of this variable is +interpreted as a multiple of the mean character width of the +default face's font. + +If `shr-width' is non-nil, it overrides this variable." + :version "28.1" + :type '(choice (integer :tag "Fixed width in characters") + (const :tag "No width limit" nil))) + (defcustom shr-bullet "* " "Bullet used for unordered lists. Alternative suggestions are: @@ -135,7 +151,7 @@ same domain as the main data." This is used for cid: URLs, and the function is called with the cid: URL as the argument.") -(defvar shr-put-image-function 'shr-put-image +(defvar shr-put-image-function #'shr-put-image "Function called to put image and alt string.") (defface shr-strike-through '((t :strike-through t)) @@ -185,13 +201,15 @@ and other things: (defvar shr-depth 0) (defvar shr-warning nil) (defvar shr-ignore-cache nil) -(defvar shr-target-id nil) (defvar shr-table-separator-length 1) (defvar shr-table-separator-pixel-width 0) (defvar shr-table-id nil) (defvar shr-current-font nil) (defvar shr-internal-bullet nil) +(defvar shr-target-id nil + "Target fragment identifier anchor.") + (defvar shr-map (let ((map (make-sparse-keymap))) (define-key map "a" 'shr-show-alt-text) @@ -265,30 +283,37 @@ DOM should be a parse tree as generated by (shr-table-separator-pixel-width (shr-string-pixel-width "-")) (shr-internal-bullet (cons shr-bullet (shr-string-pixel-width shr-bullet))) - (shr-internal-width (or (and shr-width - (if (not shr-use-fonts) - shr-width - (* shr-width (frame-char-width)))) - ;; We need to adjust the available - ;; width for when the user disables - ;; the fringes, which will cause the - ;; display engine usurp one column for - ;; the continuation glyph. - (if (not shr-use-fonts) - (- (window-body-width) 1 - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - 0 - 1)) - (- (window-body-width nil t) - (* 2 (frame-char-width)) - (if (and (null shr-width) - (not (shr--have-one-fringe-p))) - (* (frame-char-width) 2) - 0) - 1)))) + (shr-internal-width + (if shr-width + ;; Specified width; use it. + (if (not shr-use-fonts) + shr-width + (* shr-width (frame-char-width))) + ;; Compute the width based on the window width. We need to + ;; adjust the available width for when the user disables + ;; the fringes, which will cause the display engine usurp + ;; one column for the continuation glyph. + (if (not shr-use-fonts) + (- (window-body-width) 1 + (if (shr--have-one-fringe-p) + 1 + 0)) + (- (window-body-width nil t) + (* 2 (frame-char-width)) + (if (shr--have-one-fringe-p) + 0 + (* (frame-char-width) 2)) + 1)))) (max-specpdl-size max-specpdl-size) bidi-display-reordering) + ;; Adjust for max width specification. + (when (and shr-max-width + (not shr-width)) + (setq shr-internal-width + (min shr-internal-width + (if shr-use-fonts + (* shr-max-width (frame-char-width)) + shr-max-width)))) ;; If the window was hscrolled for some reason, shr-fill-lines ;; below will misbehave, because it silently assumes that it ;; starts with a non-hscrolled window (vertical-motion will move @@ -365,25 +390,20 @@ If the URL is already at the front of the kill ring act like (shr-copy-url url))) (defun shr--current-link-region () - (let ((current (get-text-property (point) 'shr-url)) - start) - (save-excursion - ;; Go to the beginning. - (while (and (not (bobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char -1)) - (unless (equal (get-text-property (point) 'shr-url) current) - (forward-char 1)) - (setq start (point)) - ;; Go to the end. - (while (and (not (eobp)) - (equal (get-text-property (point) 'shr-url) current)) - (forward-char 1)) - (list start (point))))) + "Return the start and end positions of the URL at point, if any. +Value is a pair of positions (START . END) if there is a non-nil +`shr-url' text property at point; otherwise nil." + (when (get-text-property (point) 'shr-url) + (let* ((end (or (next-single-property-change (point) 'shr-url) + (point-max))) + (beg (or (previous-single-property-change end 'shr-url) + (point-min)))) + (cons beg end)))) (defun shr--blink-link () - (let* ((region (shr--current-link-region)) - (overlay (make-overlay (car region) (cadr region)))) + "Briefly fontify URL at point with the face `shr-selected-link'." + (when-let* ((region (shr--current-link-region)) + (overlay (make-overlay (car region) (cdr region)))) (overlay-put overlay 'face 'shr-selected-link) (run-at-time 1 nil (lambda () (delete-overlay overlay))))) @@ -437,7 +457,7 @@ the URL of the image to the kill buffer instead." (if (not url) (message "No image under point") (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker)) t)))) @@ -463,7 +483,7 @@ size, and full-buffer size." (when (> (- (point) start) 2) (delete-region start (1- (point))))) (message "Inserting %s..." url) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) (1- (point)) (point-marker) (list (cons 'size (cond ((or (eq size 'default) @@ -493,7 +513,7 @@ size, and full-buffer size." ((fboundp function) (apply function dom args)) (t - (apply 'shr-generic dom args))))) + (apply #'shr-generic dom args))))) (defun shr-descend (dom) (let ((function @@ -531,13 +551,13 @@ size, and full-buffer size." (funcall function dom)) (t (shr-generic dom))) - (when (and shr-target-id - (equal (dom-attr dom 'id) shr-target-id)) + (when-let* ((id (dom-attr dom 'id))) ;; If the element was empty, we don't have anything to put the ;; anchor on. So just insert a dummy character. (when (= start (point)) - (insert "*")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?*) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) ;; If style is set, then this node has set the color. (when style (shr-colorize-region @@ -730,9 +750,10 @@ size, and full-buffer size." (let ((gap-start (point)) (face (get-text-property (point) 'face))) ;; Extend the background to the end of the line. - (if face - (insert (propertize "\n" 'face (shr-face-background face))) - (insert "\n")) + (insert ?\n) + (when face + (put-text-property (1- (point)) (point) + 'face (shr-face-background face))) (shr-indent) (when (and (> (1- gap-start) (point-min)) (get-text-property (point) 'shr-url) @@ -838,7 +859,7 @@ size, and full-buffer size." ;; Always chop off anchors. (when (string-match "#.*" url) (setq url (substring url 0 (match-beginning 0)))) - ;; NB: <base href="" > URI may itself be relative to the document s URI + ;; NB: <base href=""> URI may itself be relative to the document's URI. (setq url (shr-expand-url url)) (let* ((parsed (url-generic-parse-url url)) (local (url-filename parsed))) @@ -935,12 +956,11 @@ size, and full-buffer size." (defun shr-indent () (when (> shr-indentation 0) - (insert - (if (not shr-use-fonts) - (make-string shr-indentation ?\s) - (propertize " " - 'display - `(space :width (,shr-indentation))))))) + (if (not shr-use-fonts) + (insert-char ?\s shr-indentation) + (insert ?\s) + (put-text-property (1- (point)) (point) + 'display `(space :width (,shr-indentation)))))) (defun shr-fontize-dom (dom &rest types) (let ((start (point))) @@ -987,16 +1007,11 @@ the mouse click event." (cond ((not url) (message "No link under point")) - ((string-match "^mailto:" url) - (browse-url-mail url)) + (external + (funcall browse-url-secondary-browser-function url) + (shr--blink-link)) (t - (if external - (progn - (funcall browse-url-secondary-browser-function url) - (shr--blink-link)) - (browse-url url (if new-window - (not browse-url-new-window-flag) - browse-url-new-window-flag))))))) + (browse-url url (xor new-window browse-url-new-window-flag)))))) (defun shr-save-contents (directory) "Save the contents from URL in a file." @@ -1005,7 +1020,7 @@ the mouse click event." (if (not url) (message "No link under point") (url-retrieve (shr-encode-url url) - 'shr-store-contents (list url directory))))) + #'shr-store-contents (list url directory))))) (defun shr-store-contents (status url directory) (unless (plist-get status :error) @@ -1156,7 +1171,6 @@ width/height instead." ;; url-cache-extract autoloads url-cache. (declare-function url-cache-create-filename "url-cache" (url)) -(autoload 'browse-url-mail "browse-url") (defun shr-get-image-data (url) "Get image data for URL. @@ -1230,7 +1244,7 @@ START, and END. Note that START and END should be markers." (funcall shr-put-image-function image (buffer-substring start end)) (delete-region (point) end)))) - (url-retrieve url 'shr-image-fetched + (url-retrieve url #'shr-image-fetched (list (current-buffer) start end) t t))))) @@ -1265,7 +1279,9 @@ START, and END. Note that START and END should be markers." (format "%s (%s)" iri title) iri)) 'follow-link t - 'mouse-face 'highlight)) + ;; Make separate regions not `eq' so that they'll get + ;; separate mouse highlights. + 'mouse-face (list 'highlight))) ;; Don't overwrite any keymaps that are already in the buffer (i.e., ;; image keymaps). (while (and start @@ -1438,7 +1454,7 @@ ones, in case fg and bg are nil." (shr-fontize-dom dom 'underline)) (defun shr-tag-code (dom) - (let ((shr-current-font 'default)) + (let ((shr-current-font 'fixed-pitch)) (shr-generic dom))) (defun shr-tag-tt (dom) @@ -1495,14 +1511,13 @@ ones, in case fg and bg are nil." (start (point)) shr-start) (shr-generic dom) - (when (and shr-target-id - (equal (dom-attr dom 'name) shr-target-id)) - ;; We have a zero-length <a name="foo"> element, so just - ;; insert... something. + (when-let* ((id (unless (dom-attr dom 'id) ; Handled by `shr-descend'. + (dom-attr dom 'name)))) ; Obsolete since HTML5. + ;; We have an empty element, so just insert... something. (when (= start (point)) - (shr-ensure-newline) - (insert " ")) - (put-text-property start (1+ start) 'shr-target-id shr-target-id)) + (insert ?\s) + (put-text-property (1- (point)) (point) 'display "")) + (put-text-property start (1+ start) 'shr-target-id id)) (when url (shr-urlify (or shr-start start) (shr-expand-url url) title)))) @@ -1677,7 +1692,7 @@ The preference is a float determined from `shr-prefer-media-type'." (or alt ""))) (insert " ") (url-queue-retrieve - (shr-encode-url url) 'shr-image-fetched + (shr-encode-url url) #'shr-image-fetched (list (current-buffer) start (set-marker (make-marker) (point)) (list :width width :height height)) t @@ -2004,12 +2019,11 @@ BASE is the URL of the HTML being rendered." (cond ((null tbodies) dom) - ((= (length tbodies) 1) + ((null (cdr tbodies)) (car tbodies)) (t ;; Table with multiple tbodies. Convert into a single tbody. - `(tbody nil ,@(cl-reduce 'append - (mapcar 'dom-non-text-children tbodies))))))) + `(tbody nil ,@(mapcan #'dom-non-text-children tbodies)))))) (defun shr--fix-tbody (tbody) (nconc (list 'tbody (dom-attributes tbody)) @@ -2309,8 +2323,8 @@ flags that control whether to collect or render objects." (dolist (column row) (aset natural-widths i (max (aref natural-widths i) column)) (setq i (1+ i))))) - (let ((extra (- (apply '+ (append suggested-widths nil)) - (apply '+ (append widths nil)) + (let ((extra (- (apply #'+ (append suggested-widths nil)) + (apply #'+ (append widths nil)) (* shr-table-separator-pixel-width (1+ (length widths))))) (expanded-columns 0)) ;; We have extra, unused space, so divide this space amongst the @@ -2585,12 +2599,28 @@ flags that control whether to collect or render objects." i)) (defun shr-max-columns (dom) - (let ((max 0)) + (let ((max 0) + (this 0) + (rowspans nil)) (dolist (row (dom-children dom)) (when (and (not (stringp row)) (eq (dom-tag row) 'tr)) - (setq max (max max (+ (shr-count row 'td) - (shr-count row 'th)))))) + (setq this 0) + (dolist (column (dom-children row)) + (when (and (not (stringp column)) + (memq (dom-tag column) '(td th))) + (setq this (+ 1 this (length rowspans))) + ;; We have a rowspan, which we emulate later in rendering + ;; by adding an extra column to the following rows. + (when-let* ((span (dom-attr column 'rowspan))) + (push (string-to-number span) rowspans)))) + (setq max (max max this))) + ;; Count down the rowspans in effect. + (let ((new nil)) + (dolist (span rowspans) + (when (> span 1) + (push (1- span) new))) + (setq rowspans new))) max)) (provide 'shr) diff --git a/lisp/net/tramp-adb.el b/lisp/net/tramp-adb.el index 5cfcb81708f..c1eb36e3405 100644 --- a/lisp/net/tramp-adb.el +++ b/lisp/net/tramp-adb.el @@ -55,15 +55,27 @@ It is used for TCP/IP devices." "When this method name is used, forward all calls to Android Debug Bridge.") ;;;###tramp-autoload -(defcustom tramp-adb-prompt - "^[[:digit:]]*|?[[:alnum:]\e;[]*@?[[:alnum:]]*[^#\\$]*[#\\$][[:space:]]" +(defcustom tramp-adb-prompt "^[^#$\n\r]*[#$][[:space:]]" "Regexp used as prompt in almquist shell." :type 'regexp - :version "24.4" + :version "28.1" :group 'tramp) +(eval-and-compile + (defconst tramp-adb-ls-date-year-regexp + "[[:digit:]]\\{4\\}-[[:digit:]]\\{2\\}-[[:digit:]]\\{2\\}" + "Regexp for date year format in ls output.")) + +(eval-and-compile + (defconst tramp-adb-ls-date-time-regexp + "[[:digit:]]\\{2\\}:[[:digit:]]\\{2\\}" + "Regexp for date time format in ls output.")) + (defconst tramp-adb-ls-date-regexp - "[[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]][0-9][0-9]:[0-9][0-9][[:space:]]" + (concat + "[[:space:]]" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp + "[[:space:]]") "Regexp for date format in ls output.") (defconst tramp-adb-ls-toolbox-regexp @@ -73,7 +85,8 @@ It is used for TCP/IP devices." "[[:space:]]*\\([^[:space:]]+\\)" ; \2 username "[[:space:]]+\\([^[:space:]]+\\)" ; \3 group "[[:space:]]+\\([[:digit:]]+\\)" ; \4 size - "[[:space:]]+\\([-[:digit:]]+[[:space:]][:[:digit:]]+\\)" ; \5 date + "[[:space:]]+\\(" tramp-adb-ls-date-year-regexp + "[[:space:]]" tramp-adb-ls-date-time-regexp "\\)" ; \5 date "[[:space:]]\\(.*\\)$") ; \6 filename "Regexp for ls output.") @@ -136,7 +149,7 @@ It is used for TCP/IP devices." (file-selinux-context . tramp-handle-file-selinux-context) (file-symlink-p . tramp-handle-file-symlink-p) (file-system-info . tramp-adb-handle-file-system-info) - (file-truename . tramp-adb-handle-file-truename) + (file-truename . tramp-handle-file-truename) (file-writable-p . tramp-adb-handle-file-writable-p) (find-backup-file-name . tramp-handle-find-backup-file-name) ;; `get-file-buffer' performed by default handler. @@ -160,6 +173,8 @@ It is used for TCP/IP devices." (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -181,10 +196,9 @@ It is used for TCP/IP devices." "Invoke the ADB handler for OPERATION. First arg specifies the OPERATION, second arg is a list of ARGUMENTS to pass to the OPERATION." - (let ((fn (assoc operation tramp-adb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) arguments)) - (tramp-run-real-handler operation arguments)))) + (if-let ((fn (assoc operation tramp-adb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) arguments)) + (tramp-run-real-handler operation arguments))) ;;;###tramp-autoload (tramp--with-startup @@ -214,11 +228,10 @@ ARGUMENTS to pass to the OPERATION." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*[^[:space:]]+" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*[^[:space:]]+" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) ;; The values are given as 1k numbers, so we must change ;; them to number of bytes. (list (* 1024 (string-to-number (match-string 1))) @@ -228,105 +241,6 @@ ARGUMENTS to pass to the OPERATION." (string-to-number (match-string 2)))) (* 1024 (string-to-number (match-string 3))))))))) -;; This is derived from `tramp-sh-handle-file-truename'. Maybe the -;; code could be shared? -(defun tramp-adb-handle-file-truename (filename) - "Like `file-truename' for Tramp files." - ;; Preserve trailing "/". - (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) - ;; Quote properly. - (funcall - (if (tramp-compat-file-name-quoted-p filename) - #'tramp-compat-file-name-quote #'identity) - (with-parsed-tramp-file-name - (tramp-compat-file-name-unquote (expand-file-name filename)) nil - (tramp-make-tramp-file-name - v - (with-tramp-file-property v localname "file-truename" - (let (result) ; result steps in reverse order - (tramp-message v 4 "Finding true name for `%s'" filename) - (let* ((steps (split-string localname "/" 'omit)) - (localnamedir (tramp-run-real-handler - 'file-name-as-directory (list localname))) - (is-dir (string= localname localnamedir)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; otherwise - ;; they might think that Emacs is hung. Of course, - ;; correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/"))))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - ;; If the symlink was absolute, we'll get a string - ;; like "/user@host:/some/target"; extract the - ;; "/some/target" part from it. - (when (tramp-tramp-file-p symlink-target) - (unless (tramp-equal-remote filename symlink-target) - (tramp-error - v 'file-error - "Symlink target `%s' on wrong host" symlink-target)) - (setq symlink-target localname)) - (setq steps - (append (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result - (string-join (cons "" result) "/") - "/")) - (when (and is-dir (or (string-empty-p result) - (not (string= (substring result -1) "/")))) - (setq result (concat result "/")))) - - ;; Detect cycle. - (when (and (file-symlink-p filename) - (string-equal result localname)) - (tramp-error - v 'file-error - "Apparent cycle of symbolic links for %s" filename)) - ;; If the resulting localname looks remote, we must quote it - ;; for security reasons. - (when (file-remote-p result) - (setq result (tramp-compat-file-name-quote result 'top))) - (tramp-message v 4 "True name of `%s' is `%s'" localname result) - result))))))) - (defun tramp-adb-handle-file-attributes (filename &optional id-format) "Like `file-attributes' for Tramp files." (unless id-format (setq id-format 'integer)) @@ -370,7 +284,9 @@ ARGUMENTS to pass to the OPERATION." (if (eq id-format 'integer) 0 uid) (if (eq id-format 'integer) 0 gid) tramp-time-dont-know ; atime - (date-to-time date) ; mtime + ;; `date-to-time' checks `iso8601-parse', which might fail. + (let (signal-hook-function) + (date-to-time date)) ; mtime tramp-time-dont-know ; ctime size mod-string @@ -449,21 +365,6 @@ ARGUMENTS to pass to the OPERATION." "ls --color=never") (t "ls")))) -(defun tramp-adb--gnu-switches-to-ash (switches) - "Almquist shell can't handle multiple arguments. -Convert (\"-al\") to (\"-a\" \"-l\"). Remove arguments like \"--dired\"." - (split-string - (apply #'concat - (mapcar (lambda (s) - (replace-regexp-in-string - "\\(.\\)" " -\\1" (replace-regexp-in-string "^-" "" s))) - ;; FIXME: Warning about removed switches (long and non-dash). - (delq nil - (mapcar - (lambda (s) - (and (not (string-match-p "\\(^--\\|^[^-]\\)" s)) s)) - switches)))))) - (defun tramp-adb-sh-fix-ls-output (&optional sort-by-time) "Insert dummy 0 in empty size columns. Android's \"ls\" command doesn't insert size column for directories: @@ -473,10 +374,16 @@ Emacs dired can't find files." (goto-char (point-min)) (while (search-forward-regexp - "[[:space:]]\\([[:space:]][0-9]\\{4\\}-[0-9][0-9]-[0-9][0-9][[:space:]]\\)" nil t) + (eval-when-compile + (concat + "[[:space:]]" + "\\([[:space:]]" tramp-adb-ls-date-year-regexp "[[:space:]]\\)")) + nil t) (replace-match "0\\1" "\\1" nil) ;; Insert missing "/". - (when (looking-at-p "[0-9][0-9]:[0-9][0-9][[:space:]]+$") + (when (looking-at-p + (eval-when-compile + (concat tramp-adb-ls-date-time-regexp "[[:space:]]+$"))) (end-of-line) (insert "/"))) ;; Sort entries. @@ -587,9 +494,10 @@ Emacs dired can't find files." (with-tramp-progress-reporter v 3 (format "Fetching %s to tmp file %s" filename tmpfile) ;; "adb pull ..." does not always return an error code. - (when (or (tramp-adb-execute-adb-command - v "pull" (tramp-compat-file-name-unquote localname) tmpfile) - (not (file-exists-p tmpfile))) + (unless + (and (tramp-adb-execute-adb-command + v "pull" (tramp-compat-file-name-unquote localname) tmpfile) + (file-exists-p tmpfile)) (ignore-errors (delete-file tmpfile)) (tramp-error v 'file-error "Cannot make local copy of file `%s'" filename)) @@ -631,9 +539,6 @@ But handle the case, if the \"test\" command is not available." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let* ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -645,11 +550,15 @@ But handle the case, if the \"test\" command is not available." v 3 (format-message "Moving tmp file `%s' to `%s'" tmpfile filename) (unwind-protect - (when (tramp-adb-execute-adb-command - v "push" tmpfile (tramp-compat-file-name-unquote localname)) + (unless (tramp-adb-execute-adb-command + v "push" tmpfile (tramp-compat-file-name-unquote localname)) (tramp-error v 'file-error "Cannot write: `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -667,13 +576,16 @@ But handle the case, if the \"test\" command is not available." (tramp-message v 0 "Wrote %s" filename)) (run-hooks 'tramp-handle-write-region-hook)))) -(defun tramp-adb-handle-set-file-modes (filename mode) +(defun tramp-adb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (tramp-adb-send-command-and-check v (format "chmod %o %s" mode localname)))) + ;; ADB shell does not support "chmod -h". + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (tramp-adb-send-command-and-check + v (format "chmod %o %s" mode (tramp-shell-quote-argument localname)))))) -(defun tramp-adb-handle-set-file-times (filename &optional time) +(defun tramp-adb-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -682,21 +594,23 @@ But handle the case, if the \"test\" command is not available." (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) time)) + (nofollow (if (eq flag 'nofollow) "-h" "")) (quoted-name (tramp-shell-quote-argument localname))) ;; Older versions of toybox 'touch' mishandle nanoseconds and/or ;; trailing "Z", so fall back on plain seconds if nanoseconds+Z ;; fails. Also, fall back on old POSIX 'touch -t' if 'touch -d' ;; (introduced in POSIX.1-2008) fails. (tramp-adb-send-command-and-check - v (format (concat "touch -d %s %s 2>/dev/null || " - "touch -d %s %s 2>/dev/null || " - "touch -t %s %s") - (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) - quoted-name - (format-time-string "%Y-%m-%dT%H:%M:%S" time t) - quoted-name - (format-time-string "%Y%m%d%H%M.%S" time t) - quoted-name))))) + v (format + (concat "touch -d %s %s %s 2>/dev/null || " + "touch -d %s %s %s 2>/dev/null || " + "touch -t %s %s %s") + (format-time-string "%Y-%m-%dT%H:%M:%S.%NZ" time t) + nofollow quoted-name + (format-time-string "%Y-%m-%dT%H:%M:%S" time t) + nofollow quoted-name + (format-time-string "%Y%m%d%H%M.%S" time t) + nofollow quoted-name))))) (defun tramp-adb-handle-copy-file (filename newname &optional ok-if-already-exists keep-date @@ -719,14 +633,14 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter v 0 (format "Copying %s to %s" filename newname) (if (and t1 t2 (tramp-equal-remote filename newname)) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, ;; because `file-attributes' reads the values from ;; there. @@ -739,46 +653,45 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (tramp-shell-quote-argument l2)) "Error copying %s to %s" filename newname)) - (let ((tmpfile (file-local-copy filename))) - - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. - (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name - (file-name-nondirectory filename) newname))) - - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) - (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - - ;; We must also flush the cache of the directory, - ;; because `file-attributes' reads the values from - ;; there. - (tramp-flush-file-properties v localname) - (when (tramp-adb-execute-adb-command + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name + (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) + (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + + ;; We must also flush the cache of the directory, + ;; because `file-attributes' reads the values from + ;; there. + (tramp-flush-file-properties v localname) + (unless (tramp-adb-execute-adb-command v "push" (tramp-compat-file-name-unquote filename) (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error - "Cannot copy `%s' `%s'" filename newname))))))))) + (tramp-error + v 'file-error + "Cannot copy `%s' `%s'" filename newname)))))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-adb-handle-rename-file (filename newname &optional ok-if-already-exists) @@ -801,7 +714,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -809,8 +722,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (if (and t1 t2 (tramp-equal-remote filename newname) (not (file-directory-p filename))) - (let ((l1 (tramp-compat-file-local-name filename)) - (l2 (tramp-compat-file-local-name newname))) + (let ((l1 (tramp-file-local-name filename)) + (l2 (tramp-file-local-name newname))) ;; We must also flush the cache of the directory, because ;; `file-attributes' reads the values from there. (tramp-flush-file-properties v l1) @@ -846,7 +759,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -877,8 +790,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -895,14 +807,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; it. Call it in a subshell, in order to preserve working ;; directory. (condition-case nil - (progn - (setq ret - (if (tramp-adb-send-command-and-check - v - (format "(cd %s; %s)" - (tramp-shell-quote-argument localname) command)) - ;; Set return status accordingly. - 0 1)) + (unwind-protect + (setq ret (tramp-adb-send-command-and-check + v (format + "(cd %s; %s)" + (tramp-shell-quote-argument localname) command) + t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -918,6 +829,12 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (> ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -936,6 +853,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-adb-handle-make-process (&rest args) "Like `make-process' for Tramp files." (when args @@ -969,17 +888,29 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) (command - (format "cd %s && exec %s" + (format "cd %s && exec %s %s" (tramp-shell-quote-argument localname) + (if tmpstderr (format "2>'%s'" tmpstderr) "") (mapconcat #'tramp-shell-quote-argument (cons program args) " "))) (tramp-process-connection-type @@ -1029,6 +960,18 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Read initial output. Remove the first line, ;; which is the command echo. (while @@ -1037,6 +980,23 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (not (re-search-forward "[\n]" nil t))) (tramp-accept-process-output p 0)) (delete-region (point-min) (point)) + ;; Provide error buffer. This shows only + ;; initial error messages; messages arriving + ;; later on will be inserted when the process + ;; is deleted. The temporary file will exist + ;; until the process is deleted. + (when (bufferp stderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr 'visit nil nil 'replace)) + (delete-file remote-tmpstderr)))) ;; Return process. p)))) @@ -1053,7 +1013,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." "Like `exec-path' for Tramp files." (append (with-parsed-tramp-file-name default-directory nil - (with-tramp-connection-property v "remote-path" + (with-tramp-connection-property (tramp-get-process v) "remote-path" (tramp-adb-send-command v "echo \\\"$PATH\\\"") (split-string (with-current-buffer (tramp-get-connection-buffer v) @@ -1062,17 +1022,13 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (read (current-buffer))) ":" 'omit))) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-adb-get-device (vec) "Return full host name from VEC to be used in shell execution. E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" a host name \"R38273882DE\" returns \"R38273882DE\"." - ;; Sometimes this is called before there is a connection process - ;; yet. In order to work with the connection cache, we flush all - ;; unwanted entries first. - (tramp-flush-connection-properties nil) - (with-tramp-connection-property (tramp-get-connection-process vec) "device" + (with-tramp-connection-property (tramp-get-process vec) "device" (let* ((host (tramp-file-name-host vec)) (port (tramp-file-name-port-or-default vec)) (devices (mapcar #'cadr (tramp-adb-parse-device-names nil)))) @@ -1090,10 +1046,10 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" ;; Try to connect device. ((and tramp-adb-connect-if-not-connected (not (zerop (length host))) - (not (tramp-adb-execute-adb-command - vec "connect" - (replace-regexp-in-string - tramp-prefix-port-format ":" host)))) + (tramp-adb-execute-adb-command + vec "connect" + (replace-regexp-in-string + tramp-prefix-port-format ":" host))) ;; When new device connected, running other adb command (e.g. ;; adb shell) immediately will fail. To get around this ;; problem, add sleep 0.1 second here. @@ -1103,18 +1059,18 @@ E.g. a host name \"192.168.1.1#5555\" returns \"192.168.1.1:5555\" vec 'file-error "Could not find device %s" host))))))) (defun tramp-adb-execute-adb-command (vec &rest args) - "Return nil on success error-output on failure." + "Execute an adb command. +Insert the result into the connection buffer. Return nil on +error and non-nil on success." (when (and (> (length (tramp-file-name-host vec)) 0) ;; The -s switch is only available for ADB device commands. (not (member (car args) '("connect" "disconnect")))) (setq args (append (list "-s" (tramp-adb-get-device vec)) args))) - (with-temp-buffer - (prog1 - (unless - (zerop - (apply #'tramp-call-process vec tramp-adb-program nil t nil args)) - (buffer-string)) - (tramp-message vec 6 "%s" (buffer-string))))) + (with-current-buffer (tramp-get-connection-buffer vec) + ;; Clean up the buffer. We cannot call `erase-buffer' because + ;; narrowing might be in effect. + (let ((inhibit-read-only t)) (delete-region (point-min) (point-max))) + (zerop (apply #'tramp-call-process vec tramp-adb-program nil t nil args)))) (defun tramp-adb-find-test-command (vec) "Check whether the ash has a builtin \"test\" command. @@ -1126,42 +1082,52 @@ This happens for Android >= 4.0." (defun tramp-adb-send-command (vec command &optional neveropen nooutput) "Send the COMMAND to connection VEC." - (unless neveropen (tramp-adb-maybe-open-connection vec)) - (tramp-message vec 6 "%s" command) - (tramp-send-string vec command) - (unless nooutput - ;; FIXME: Race condition. - (tramp-adb-wait-for-output (tramp-get-connection-process vec)) - (with-current-buffer (tramp-get-connection-buffer vec) - (save-excursion - (goto-char (point-min)) - ;; We can't use stty to disable echo of command. stty is said - ;; to be added to toybox 0.7.6. busybox shall have it, but this - ;; isn't used any longer for Android. - (delete-matching-lines (regexp-quote command)) - ;; When the local machine is W32, there are still trailing ^M. - ;; There must be a better solution by setting the correct coding - ;; system, but this requires changes in core Tramp. - (goto-char (point-min)) - (while (re-search-forward "\r+$" nil t) - (replace-match "" nil nil)))))) + (if (string-match-p "[[:multibyte:]]" command) + ;; Multibyte codepoints with four bytes are not supported at + ;; least by toybox. + (tramp-adb-execute-adb-command vec "shell" command) + + (unless neveropen (tramp-adb-maybe-open-connection vec)) + (tramp-message vec 6 "%s" command) + (tramp-send-string vec command) + (unless nooutput + ;; FIXME: Race condition. + (tramp-adb-wait-for-output (tramp-get-connection-process vec)) + (with-current-buffer (tramp-get-connection-buffer vec) + (save-excursion + (goto-char (point-min)) + ;; We can't use stty to disable echo of command. stty is said + ;; to be added to toybox 0.7.6. busybox shall have it, but this + ;; isn't used any longer for Android. + (delete-matching-lines (regexp-quote command)) + ;; When the local machine is W32, there are still trailing ^M. + ;; There must be a better solution by setting the correct coding + ;; system, but this requires changes in core Tramp. + (goto-char (point-min)) + (while (re-search-forward "\r+$" nil t) + (replace-match "" nil nil))))))) -(defun tramp-adb-send-command-and-check (vec command) +(defun tramp-adb-send-command-and-check (vec command &optional exit-status) "Run COMMAND and check its exit status. Sends `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just sends `echo $?'. Returns nil if -the exit status is not equal 0, and t otherwise." +the exit status is not equal 0, and t otherwise. + +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-adb-send-command vec (if command (format "%s; echo tramp_exit_status $?" command) "echo tramp_exit_status $?")) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -1263,7 +1229,11 @@ connection if a previous connection has died for some reason." ;; connection properties. We start again. (tramp-message vec 5 "Checking system information") (tramp-adb-send-command - vec "echo \\\"`getprop ro.product.model` `getprop ro.product.version` `getprop ro.build.version.release`\\\"") + vec + (concat + "echo \\\"`getprop ro.product.model` " + "`getprop ro.product.version` " + "`getprop ro.build.version.release`\\\"")) (let ((old-getprop (tramp-get-connection-property vec "getprop" nil)) (new-getprop @@ -1287,7 +1257,8 @@ connection if a previous connection has died for some reason." (tramp-adb-send-command vec (format "su %s" user)) (unless (tramp-adb-send-command-and-check vec nil) (delete-process p) - (tramp-flush-file-property vec "" "su-command-p") + ;; Do not flush, we need the nil value. + (tramp-set-file-property vec "" "su-command-p" nil) (tramp-error vec 'file-error "Cannot switch to user `%s'" user))) @@ -1321,4 +1292,9 @@ connection if a previous connection has died for some reason." (provide 'tramp-adb) +;;; TODO: +;; +;; * Support file names with multibyte codepoints. Use as fallback +;; "adb shell COMMAND". +;; ;;; tramp-adb.el ends here diff --git a/lisp/net/tramp-archive.el b/lisp/net/tramp-archive.el index b9bf6180a5d..9502cc35300 100644 --- a/lisp/net/tramp-archive.el +++ b/lisp/net/tramp-archive.el @@ -109,7 +109,7 @@ (eval-when-compile (require 'cl-lib)) ;; Sometimes, compilation fails with "Variable binding depth exceeds -;; max-specpdl-size". +;; max-specpdl-size". Shall be fixed in Emacs 27. (eval-and-compile (let ((max-specpdl-size (* 2 max-specpdl-size))) (require 'tramp-gvfs))) @@ -279,7 +279,9 @@ It must be supported by libarchive(3).") (start-file-process . tramp-archive-handle-not-implemented) ;; `substitute-in-file-name' performed by default handler. (temporary-file-directory . tramp-archive-handle-temporary-file-directory) - ;; `tramp-set-file-uid-gid' performed by default handler. + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) + (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) @@ -318,7 +320,10 @@ arguments to pass to the OPERATION." (let* ((filename (apply #'tramp-archive-file-name-for-operation operation args)) - (archive (tramp-archive-file-name-archive filename))) + (archive (tramp-archive-file-name-archive filename)) + ;; Sometimes, it fails with "Variable binding depth exceeds + ;; max-specpdl-size". Shall be fixed in Emacs 27. + (max-specpdl-size (* 2 max-specpdl-size))) ;; `filename' could be a quoted file name. Or the file ;; archive could be a directory, see Bug#30293. @@ -350,7 +355,7 @@ arguments to pass to the OPERATION." (add-to-list 'file-name-handler-alist (cons (tramp-archive-autoload-file-name-regexp) #'tramp-archive-autoload-file-name-handler)) - (put 'tramp-archive-autoload-file-name-handler 'safe-magic t)))) + (put #'tramp-archive-autoload-file-name-handler 'safe-magic t)))) ;;;###autoload (progn @@ -366,7 +371,7 @@ arguments to pass to the OPERATION." (tramp-register-archive-file-name-handler) ;; Mark `operations' the handler is responsible for. -(put 'tramp-archive-file-name-handler 'operations +(put #'tramp-archive-file-name-handler 'operations (mapcar #'car tramp-archive-file-name-handler-alist)) ;; `tramp-archive-file-name-handler' must be placed before `url-file-handler'. @@ -517,13 +522,16 @@ offered." (declare (debug (form symbolp body)) (indent 2)) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(cons - 'archive - (delete 'hop (tramp-compat-tramp-file-name-slots)))))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cons + 'archive + (delete + 'hop + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))))) `(let* ((,(or var 'v) (tramp-archive-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, diff --git a/lisp/net/tramp-cache.el b/lisp/net/tramp-cache.el index 62e25fa1f08..970e2eea0ac 100644 --- a/lisp/net/tramp-cache.el +++ b/lisp/net/tramp-cache.el @@ -31,13 +31,13 @@ ;; a process, has a unique cache. We distinguish 4 kind of caches, ;; depending on the key: ;; -;; - localname is NIL. This are reusable properties. Examples: +;; - localname is nil. These are reusable properties. Examples: ;; "remote-shell" identifies the POSIX shell to be called on the ;; remote host, or "perl" is the command to be called on the remote ;; host when starting a Perl script. These properties are saved in ;; the file `tramp-persistency-file-name'. ;; -;; - localname is a string. This are temporary properties, which are +;; - localname is a string. These are temporary properties, which are ;; related to the file localname is referring to. Examples: ;; "file-exists-p" is t or nil, depending on the file existence, or ;; "file-attributes" caches the result of the function @@ -45,21 +45,32 @@ ;; expire after `remote-file-name-inhibit-cache' seconds if this ;; variable is set. ;; -;; - The key is a process. This are temporary properties related to +;; - The key is a process. These are temporary properties related to ;; an open connection. Examples: "scripts" keeps shell script ;; definitions already sent to the remote shell, "last-cmd-time" is ;; the time stamp a command has been sent to the remote process. ;; -;; - The key is nil. This are temporary properties related to the +;; - The key is nil. These are temporary properties related to the ;; local machine. Examples: "parse-passwd" and "parse-group" keep ;; the results of parsing "/etc/passwd" and "/etc/group", ;; "{uid,gid}-{integer,string}" are the local uid and gid, and ;; "locale" is the used shell locale. +;; +;; - The key is `tramp-cache-undefined'. All functions return the +;; expected values, but nothing is cached. ;; Some properties are handled special: ;; ;; - "process-name", "process-buffer" and "first-password-request" are -;; not saved in the file `tramp-persistency-file-name'. +;; not saved in the file `tramp-persistency-file-name', although +;; being connection properties related to a `tramp-file-name' +;; structure. +;; +;; - Reusable properties, which should not be saved, are kept in the +;; process key retrieved by `tramp-get-process' (the main connection +;; process). Other processes could reuse these properties, avoiding +;; recomputation when a new asynchronous process is created by +;; `make-process'. Examples are "remote-path" or "device" (tramp-adb.el). ;;; Code: @@ -96,25 +107,31 @@ details see the info pages." (defvar tramp-cache-data-changed nil "Whether persistent cache data have been changed.") +;;;###tramp-autoload +(defconst tramp-cache-undefined 'undef + "The symbol marking undefined hash keys and values.") + (defun tramp-get-hash-table (key) "Return the hash table for KEY. If it doesn't exist yet, it is created and initialized with -matching entries of `tramp-connection-properties'." - (or (gethash key tramp-cache-data) - (let ((hash - (puthash key (make-hash-table :test #'equal) tramp-cache-data))) - (when (tramp-file-name-p key) - (dolist (elt tramp-connection-properties) - (when (string-match-p - (or (nth 0 elt) "") - (tramp-make-tramp-file-name key 'noloc 'nohop)) - (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) - hash))) +matching entries of `tramp-connection-properties'. +If KEY is `tramp-cache-undefined', don't create anything, and return nil." + (unless (eq key tramp-cache-undefined) + (or (gethash key tramp-cache-data) + (let ((hash + (puthash key (make-hash-table :test #'equal) tramp-cache-data))) + (when (tramp-file-name-p key) + (dolist (elt tramp-connection-properties) + (when (string-match-p + (or (nth 0 elt) "") + (tramp-make-tramp-file-name key 'noloc 'nohop)) + (tramp-set-connection-property key (nth 1 elt) (nth 2 elt))))) + hash)))) ;;;###tramp-autoload (defun tramp-get-file-property (key file property default) "Get the PROPERTY of FILE from the cache context of KEY. -Returns DEFAULT if not set." +Return DEFAULT if not set." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -122,31 +139,32 @@ Returns DEFAULT if not set." (tramp-run-real-handler #'directory-file-name (list file)) (tramp-file-name-hop key) nil) (let* ((hash (tramp-get-hash-table key)) - (value (when (hash-table-p hash) (gethash property hash)))) - (if ;; We take the value only if there is any, and - ;; `remote-file-name-inhibit-cache' indicates that it is still - ;; valid. Otherwise, DEFAULT is set. - (and (consp value) + (cached (and (hash-table-p hash) (gethash property hash))) + (cached-at (and (consp cached) (format-time-string "%T" (car cached)))) + (value default) + cache-used) + + (when ;; We take the value only if there is any, and + ;; `remote-file-name-inhibit-cache' indicates that it is + ;; still valid. Otherwise, DEFAULT is set. + (and (consp cached) (or (null remote-file-name-inhibit-cache) (and (integerp remote-file-name-inhibit-cache) (time-less-p - ;; `current-time' can be nil once we get rid of Emacs 24. - (current-time) - (time-add - (car value) - ;; `seconds-to-time' can be removed once we get - ;; rid of Emacs 24. - (seconds-to-time remote-file-name-inhibit-cache)))) + nil + (time-add (car cached) remote-file-name-inhibit-cache))) (and (consp remote-file-name-inhibit-cache) (time-less-p - remote-file-name-inhibit-cache (car value))))) - (setq value (cdr value)) - (setq value default)) + remote-file-name-inhibit-cache (car cached))))) + (setq value (cdr cached) + cache-used t)) - (tramp-message key 8 "%s %s %s" file property value) + (tramp-message + key 8 "%s %s %s; inhibit: %s; cache used: %s; cached at: %s" + file property value remote-file-name-inhibit-cache cache-used cached-at) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-get-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -157,7 +175,7 @@ Returns DEFAULT if not set." ;;;###tramp-autoload (defun tramp-set-file-property (key file property value) "Set the PROPERTY of FILE to VALUE, in the cache context of KEY. -Returns VALUE." +Return VALUE." ;; Unify localname. Remove hop from `tramp-file-name' structure. (setq file (tramp-compat-file-name-unquote file) key (copy-tramp-file-name key)) @@ -170,7 +188,7 @@ Returns VALUE." (tramp-message key 8 "%s %s %s" file property value) (when (>= tramp-verbose 10) (let* ((var (intern (concat "tramp-cache-set-count-" property))) - (val (or (bound-and-true-p var) + (val (or (numberp (bound-and-true-p var)) (progn (add-hook 'tramp-cache-unload-hook (lambda () (makunbound var))) @@ -202,13 +220,11 @@ Returns VALUE." key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) file (tramp-file-name-hop key) nil) - (maphash - (lambda (property _value) - (when (string-match-p - "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" - property) - (tramp-flush-file-property key file property))) - (tramp-get-hash-table key))))) + (dolist (property (hash-table-keys (tramp-get-hash-table key))) + (when (string-match-p + "^\\(directory-\\|file-name-all-completions\\|file-entries\\)" + property) + (tramp-flush-file-property key file property)))))) ;;;###tramp-autoload (defun tramp-flush-file-properties (key file) @@ -239,14 +255,12 @@ Remove also properties of all files in subdirectories." #'directory-file-name (list directory))) (truename (tramp-get-file-property key directory "file-truename" nil))) (tramp-message key 8 "%s" directory) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (stringp (tramp-file-name-localname key)) - (string-match-p (regexp-quote directory) - (tramp-file-name-localname key))) - (remhash key tramp-cache-data))) - tramp-cache-data) + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (tramp-file-name-p key) + (stringp (tramp-file-name-localname key)) + (string-match-p (regexp-quote directory) + (tramp-file-name-localname key))) + (remhash key tramp-cache-data))) ;; Remove file properties of symlinks. (when (and (stringp truename) (not (string-equal directory (directory-file-name truename)))) @@ -292,8 +306,9 @@ This is suppressed for temporary buffers." "Get the named PROPERTY for the connection. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. If the -value is not set for the connection, returns DEFAULT." +used to cache connection properties of the local machine. +If KEY is `tramp-cache-undefined', or if the value is not set for +the connection, return DEFAULT." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) @@ -301,15 +316,19 @@ value is not set for the connection, returns DEFAULT." (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) (let* ((hash (tramp-get-hash-table key)) - (value - ;; If the key is an auxiliary process object, check whether - ;; the process is still alive. - (if (and (processp key) (not (process-live-p key))) - default - (if (hash-table-p hash) - (gethash property hash default) - default)))) - (tramp-message key 7 "%s %s" property value) + (cached (if (hash-table-p hash) + (gethash property hash tramp-cache-undefined) + tramp-cache-undefined)) + (value default) + cache-used) + + (when (and (not (eq cached tramp-cache-undefined)) + ;; If the key is an auxiliary process object, check + ;; whether the process is still alive. + (not (and (processp key) (not (process-live-p key))))) + (setq value cached + cache-used t)) + (tramp-message key 7 "%s %s; cache used: %s" property value cache-used) value)) ;;;###tramp-autoload @@ -317,19 +336,22 @@ value is not set for the connection, returns DEFAULT." "Set the named PROPERTY of a connection to VALUE. KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is -used to cache connection properties of the local machine. -PROPERTY is set persistent when KEY is a `tramp-file-name' structure." +used to cache connection properties of the local machine. If KEY +is `tramp-cache-undefined', nothing is set. +PROPERTY is set persistent when KEY is a `tramp-file-name' structure. +Return VALUE." ;; Unify key by removing localname and hop from `tramp-file-name' ;; structure. Work with a copy in order to avoid side effects. (when (tramp-file-name-p key) (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (let ((hash (tramp-get-hash-table key))) - (puthash property value hash) - (setq tramp-cache-data-changed t) - (tramp-message key 7 "%s %s" property value) - value)) + (when-let ((hash (tramp-get-hash-table key))) + (puthash property value hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) + (tramp-message key 7 "%s %s" property value) + value) ;;;###tramp-autoload (defun tramp-connection-property-p (key property) @@ -337,7 +359,8 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." KEY identifies the connection, it is either a process or a `tramp-file-name' structure. A special case is nil, which is used to cache connection properties of the local machine." - (not (eq (tramp-get-connection-property key property 'undef) 'undef))) + (not (eq (tramp-get-connection-property key property tramp-cache-undefined) + tramp-cache-undefined))) ;;;###tramp-autoload (defun tramp-flush-connection-property (key property) @@ -352,8 +375,10 @@ PROPERTY is set persistent when KEY is a `tramp-file-name' structure." (setq key (copy-tramp-file-name key)) (setf (tramp-file-name-localname key) nil (tramp-file-name-hop key) nil)) - (remhash property (tramp-get-hash-table key)) - (setq tramp-cache-data-changed t) + (when-let ((hash (tramp-get-hash-table key))) + (remhash property hash)) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (tramp-message key 7 "%s" property)) ;;;###tramp-autoload @@ -370,12 +395,10 @@ used to cache connection properties of the local machine." (tramp-file-name-hop key) nil)) (tramp-message key 7 "%s %s" key - (let ((hash (gethash key tramp-cache-data)) - properties) - (when (hash-table-p hash) - (maphash (lambda (x _y) (push x properties)) hash)) - properties)) - (setq tramp-cache-data-changed t) + (when-let ((hash (gethash key tramp-cache-data))) + (hash-table-keys hash))) + (setq tramp-cache-data-changed + (or tramp-cache-data-changed (tramp-file-name-p key))) (remhash key tramp-cache-data)) ;;;###tramp-autoload @@ -386,20 +409,15 @@ used to cache connection properties of the local machine." (maphash (lambda (key value) ;; Remove text properties from KEY and VALUE. - ;; `cl-struct-slot-*' functions exist since Emacs 25 only; we - ;; ignore errors. (when (tramp-file-name-p key) - ;; (dolist - ;; (slot - ;; (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) - ;; (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) - ;; (setf (cl-struct-slot-value 'tramp-file-name slot key) - ;; (substring-no-properties - ;; (cl-struct-slot-value 'tramp-file-name slot key)))))) - (dotimes (i (length key)) - (when (stringp (elt key i)) - (setf (elt key i) (substring-no-properties (elt key i)))))) - (when (stringp key) + (dolist + (slot + (mapcar #'car (cdr (cl-struct-slot-info 'tramp-file-name)))) + (when (stringp (cl-struct-slot-value 'tramp-file-name slot key)) + (setf (cl-struct-slot-value 'tramp-file-name slot key) + (substring-no-properties + (cl-struct-slot-value 'tramp-file-name slot key)))))) + (when (stringp key) (setq key (substring-no-properties key))) (when (stringp value) (setq value (substring-no-properties value))) @@ -421,18 +439,18 @@ used to cache connection properties of the local machine." ;;;###tramp-autoload (defun tramp-list-connections () "Return all known `tramp-file-name' structs according to `tramp-cache'." - (let (result tramp-verbose) - (maphash - (lambda (key _value) - (when (and (tramp-file-name-p key) - (null (tramp-file-name-localname key)) - (tramp-connection-property-p key "process-buffer")) - (push key result))) - tramp-cache-data) - result)) + (let ((tramp-verbose 0)) + (delq nil (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (null (tramp-file-name-localname key)) + (tramp-connection-property-p key "process-buffer") + key)) + (hash-table-keys tramp-cache-data))))) (defun tramp-dump-connection-properties () - "Write persistent connection properties into file `tramp-persistency-file-name'." + "Write persistent connection properties into file \ +`tramp-persistency-file-name'." ;; We shouldn't fail, otherwise Emacs might not be able to be closed. (ignore-errors (when (and (hash-table-p tramp-cache-data) @@ -464,15 +482,10 @@ used to cache connection properties of the local machine." ;; Dump it. (with-temp-file tramp-persistency-file-name (insert - ";; -*- emacs-lisp -*-" - ;; `time-stamp-string' might not exist in all Emacs flavors. - (condition-case nil - (progn - (format - " <%s %s>\n" - (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") - tramp-persistency-file-name)) - (error "\n")) + ;; Starting with Emacs 28, we could use `lisp-data'. + (format ";; -*- emacs-lisp -*- <%s %s>\n" + (time-stamp-string "%02y/%02m/%02d %02H:%02M:%02S") + tramp-persistency-file-name) ";; Tramp connection history. Don't change this file.\n" ";; Run `M-x tramp-cleanup-all-connections' instead.\n\n" (with-output-to-string @@ -490,17 +503,14 @@ used to cache connection properties of the local machine." "Return a list of (user host) tuples allowed to access for METHOD. This function is added always in `tramp-get-completion-function' for all methods. Resulting data are derived from connection history." - (let (res) - (maphash - (lambda (key _value) - (if (and (tramp-file-name-p key) - (string-equal method (tramp-file-name-method key)) - (not (tramp-file-name-localname key))) - (push (list (tramp-file-name-user key) - (tramp-file-name-host key)) - res))) - tramp-cache-data) - res)) + (mapcar + (lambda (key) + (and (tramp-file-name-p key) + (string-equal method (tramp-file-name-method key)) + (not (tramp-file-name-localname key)) + (list (tramp-file-name-user key) + (tramp-file-name-host key)))) + (hash-table-keys tramp-cache-data))) ;; When "emacs -Q" has been called, both variables are nil. We do not ;; load the persistency file then, in order to have a clean test environment. @@ -514,7 +524,7 @@ for all methods. Resulting data are derived from connection history." tramp-cache-read-persistent-data) (condition-case err (with-temp-buffer - (insert-file-contents tramp-persistency-file-name) + (insert-file-contents-literally tramp-persistency-file-name) (let ((list (read (current-buffer))) (tramp-verbose 0) element key item) diff --git a/lisp/net/tramp-cmds.el b/lisp/net/tramp-cmds.el index 9d1025b9072..52cc186ecf7 100644 --- a/lisp/net/tramp-cmds.el +++ b/lisp/net/tramp-cmds.el @@ -74,11 +74,13 @@ SYNTAX can be one of the symbols `default' (default), Each function is called with the current vector as argument.") ;;;###tramp-autoload -(defun tramp-cleanup-connection (vec &optional keep-debug keep-password) +(defun tramp-cleanup-connection + (vec &optional keep-debug keep-password keep-processes) "Flush all connection related objects. This includes password cache, file cache, connection cache, -buffers. KEEP-DEBUG non-nil preserves the debug buffer. -KEEP-PASSWORD non-nil preserves the password cache. +buffers, processes. KEEP-DEBUG non-nil preserves the debug +buffer. KEEP-PASSWORD non-nil preserves the password cache. +KEEP-PROCESSES non-nil preserves the asynchronous processes. When called interactively, a Tramp connection has to be selected." (interactive ;; When interactive, select the Tramp remote identification. @@ -107,21 +109,21 @@ When called interactively, a Tramp connection has to be selected." ;; suppressed. (setq tramp-current-connection nil) - ;; Flush file cache. - (tramp-flush-directory-properties vec "") - - ;; Flush connection cache. - (when (processp (tramp-get-connection-process vec)) - (tramp-flush-connection-properties (tramp-get-connection-process vec)) - (delete-process (tramp-get-connection-process vec))) - (tramp-flush-connection-properties vec) - ;; Cancel timer. (dolist (timer timer-list) (when (and (eq (timer--function timer) 'tramp-timeout-session) (tramp-file-name-equal-p vec (car (timer--args timer)))) (cancel-timer timer))) + ;; Delete processes. + (dolist (key (hash-table-keys tramp-cache-data)) + (when (and (processp key) + (tramp-file-name-equal-p (process-get key 'vector) vec) + (or (not keep-processes) + (eq key (tramp-get-process vec)))) + (tramp-flush-connection-properties key) + (delete-process key))) + ;; Remove buffers. (dolist (buf (list (get-buffer (tramp-buffer-name vec)) @@ -130,6 +132,12 @@ When called interactively, a Tramp connection has to be selected." (tramp-get-connection-property vec "process-buffer" nil))) (when (bufferp buf) (kill-buffer buf))) + ;; Flush file cache. + (tramp-flush-directory-properties vec "") + + ;; Flush connection cache. + (tramp-flush-connection-properties vec) + ;; The end. (run-hook-with-args 'tramp-cleanup-connection-hook vec))) @@ -176,8 +184,9 @@ This includes password cache, file cache, connection cache, buffers." ;; Cancel timers. (cancel-function-timers 'tramp-timeout-session) - ;; Remove buffers. + ;; Remove processes and buffers. (dolist (name (tramp-list-tramp-buffers)) + (when (processp (get-buffer-process name)) (delete-process name)) (when (bufferp (get-buffer name)) (kill-buffer name))) ;; The end. @@ -350,15 +359,14 @@ The remote connection identified by SOURCE is flushed by (or (setq target (tramp-default-rename-file source)) (tramp-user-error nil - (eval-when-compile - (concat "There is no target specified. " - "Check `tramp-default-rename-alist' for a proper entry."))))) + (concat "There is no target specified. " + "Check `tramp-default-rename-alist' for a proper entry.")))) (when (tramp-equal-remote source target) (tramp-user-error nil "Source and target must have different remote.")) ;; Append local file name if none is specified. (when (string-equal (file-remote-p target) target) - (setq target (concat target (file-remote-p source 'localname)))) + (setq target (concat target (tramp-file-local-name source)))) ;; Make them directory names. (setq source (directory-file-name source) target (directory-file-name target)) @@ -557,11 +565,10 @@ buffer in your bug report. ;; Remove string quotation. (forward-line -1) (when (looking-at - (eval-when-compile - (concat "\\(^.*\\)" "\"" ;; \1 " - "\\((base64-decode-string \\)" "\\\\" ;; \2 \ - "\\(\".*\\)" "\\\\" ;; \3 \ - "\\(\")\\)" "\"$"))) ;; \4 " + (concat "\\(^.*\\)" "\"" ;; \1 " + "\\((base64-decode-string \\)" "\\\\" ;; \2 \ + "\\(\".*\\)" "\\\\" ;; \3 \ + "\\(\")\\)" "\"$")) ;; \4 " (replace-match "\\1\\2\\3\\4") (beginning-of-line) (insert " ;; Variable encoded due to non-printable characters.\n")) diff --git a/lisp/net/tramp-compat.el b/lisp/net/tramp-compat.el index 723b8cfa1e3..218594b551c 100644 --- a/lisp/net/tramp-compat.el +++ b/lisp/net/tramp-compat.el @@ -23,15 +23,15 @@ ;;; Commentary: -;; Tramp's main Emacs version for development is Emacs 27. This -;; package provides compatibility functions for Emacs 24, Emacs 25 and -;; Emacs 26. +;; Tramp's main Emacs version for development is Emacs 28. This +;; package provides compatibility functions for Emacs 25, Emacs 26 and +;; Emacs 27. ;;; Code: -;; In Emacs 24 and 25, `tramp-unload-file-name-handlers' is not -;; autoloaded. So we declare it here in order to avoid recursive -;; load. This will be overwritten in tramp.el. +;; In Emacs 25, `tramp-unload-file-name-handlers' is not autoloaded. +;; So we declare it here in order to avoid recursive load. This will +;; be overwritten in tramp.el. (defun tramp-unload-file-name-handlers () ".") (require 'auth-source) @@ -41,7 +41,9 @@ (require 'shell) (require 'subr-x) +;; `temporary-file-directory' as function is introduced with Emacs 26.1. (declare-function tramp-handle-temporary-file-directory "tramp") +(defvar tramp-temp-name-prefix) ;; For not existing functions, obsolete functions, or functions with a ;; changed argument list, there are compiler warnings. We want to @@ -51,6 +53,8 @@ `(when (functionp ,function) (with-no-warnings (funcall ,function ,@arguments)))) +(put #'tramp-compat-funcall 'tramp-suppress-trace t) + (defsubst tramp-compat-temporary-file-directory () "Return name of directory for temporary files. It is the default value of `temporary-file-directory'." @@ -58,15 +62,19 @@ It is the default value of `temporary-file-directory'." ;; into an infloop. (eval (car (get 'temporary-file-directory 'standard-value)))) +(defsubst tramp-compat-make-temp-name () + "Generate a local temporary file name (compat function)." + (make-temp-name + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)))) + (defsubst tramp-compat-make-temp-file (f &optional dir-flag) "Create a local temporary file (compat function). Add the extension of F, if existing." - (let* (file-name-handler-alist - (prefix (expand-file-name - (symbol-value 'tramp-temp-name-prefix) - (tramp-compat-temporary-file-directory))) - (extension (file-name-extension f t))) - (make-temp-file prefix dir-flag extension))) + (make-temp-file + (expand-file-name + tramp-temp-name-prefix (tramp-compat-temporary-file-directory)) + dir-flag (file-name-extension f t))) ;; `temporary-file-directory' as function is introduced with Emacs 26.1. (defalias 'tramp-compat-temporary-file-directory-function @@ -74,31 +82,7 @@ Add the extension of F, if existing." #'temporary-file-directory #'tramp-handle-temporary-file-directory)) -(defun tramp-compat-process-running-p (process-name) - "Return t if system process PROCESS-NAME is running for `user-login-name'." - (when (stringp process-name) - (cond - ;; GNU Emacs 22 on w32. - ((fboundp 'w32-window-exists-p) - (tramp-compat-funcall 'w32-window-exists-p process-name process-name)) - - ;; GNU Emacs 23+. - ((and (fboundp 'list-system-processes) (fboundp 'process-attributes)) - (let (result) - (dolist (pid (tramp-compat-funcall 'list-system-processes) result) - (let ((attributes (process-attributes pid))) - (when (and (string-equal - (cdr (assoc 'user attributes)) (user-login-name)) - (let ((comm (cdr (assoc 'comm attributes)))) - ;; The returned command name could be truncated - ;; to 15 characters. Therefore, we cannot check - ;; for `string-equal'. - (and comm (string-match-p - (concat "^" (regexp-quote comm)) - process-name)))) - (setq result t))))))))) - -;; `file-attribute-*' are introduced in Emacs 25.1. +;; `file-attribute-*' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-attribute-type (if (fboundp 'file-attribute-type) @@ -180,31 +164,13 @@ and later, and is a float in Emacs 26 and earlier." This is a string of ten letters or dashes as in ls -l." (nth 8 attributes)))) -;; `format-message' is new in Emacs 25.1. -(unless (fboundp 'format-message) - (defalias 'format-message #'format)) - -;; `directory-name-p' is new in Emacs 25.1. -(defalias 'tramp-compat-directory-name-p - (if (fboundp 'directory-name-p) - #'directory-name-p - (lambda (name) - "Return non-nil if NAME ends with a directory separator character." - (let ((len (length name)) - (lastc ?.)) - (if (> len 0) - (setq lastc (aref name (1- len)))) - (or (= lastc ?/) - (and (memq system-type '(windows-nt ms-dos)) - (= lastc ?\\))))))) - ;; `file-missing' is introduced in Emacs 26.1. (defconst tramp-file-missing (if (get 'file-missing 'error-conditions) 'file-missing 'file-error) "The error symbol for the `file-missing' error.") ;; `file-local-name', `file-name-quoted-p', `file-name-quote' and -;; `file-name-unquote' are introduced in Emacs 26. +;; `file-name-unquote' are introduced in Emacs 26.1. (defalias 'tramp-compat-file-local-name (if (fboundp 'file-local-name) #'file-local-name @@ -214,7 +180,8 @@ It returns a file name which can be used directly as argument of `process-file', `start-file-process', or `shell-command'." (or (file-remote-p name 'localname) name)))) -;; `file-name-quoted-p' got a second argument in Emacs 27.1. +;; `file-name-quoted-p', `file-name-quote' and `file-name-unquote' got +;; a second argument in Emacs 27.1. (defalias 'tramp-compat-file-name-quoted-p (if (and (fboundp 'file-name-quoted-p) @@ -256,7 +223,7 @@ NAME is unquoted." localname (if (= (length localname) 2) "/" (substring localname 2)))) (concat (file-remote-p name) localname))))) -;; `tramp-syntax' has changed its meaning in Emacs 26. We still +;; `tramp-syntax' has changed its meaning in Emacs 26.1. We still ;; support old settings. (defsubst tramp-compat-tramp-syntax () "Return proper value of `tramp-syntax'." @@ -265,13 +232,6 @@ NAME is unquoted." ((eq tramp-syntax 'sep) 'separate) (t tramp-syntax))) -;; `cl-struct-slot-info' has been introduced with Emacs 25. -(defmacro tramp-compat-tramp-file-name-slots () - "Return a list of slot names." - (if (fboundp 'cl-struct-slot-info) - '(cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name))) - '(cdr (mapcar #'car (get 'tramp-file-name 'cl-struct-slots))))) - ;; The signature of `tramp-make-tramp-file-name' has been changed. ;; Therefore, we cannot use `url-tramp-convert-url-to-tramp' prior ;; Emacs 26.1. We use `temporary-file-directory' as indicator. @@ -284,10 +244,9 @@ NAME is unquoted." #'exec-path (lambda () "List of directories to search programs to run in remote subprocesses." - (let ((handler (find-file-name-handler default-directory 'exec-path))) - (if handler - (funcall handler 'exec-path) - exec-path))))) + (if-let ((handler (find-file-name-handler default-directory 'exec-path))) + (funcall handler 'exec-path) + exec-path)))) ;; `time-equal-p' has appeared in Emacs 27.1. (defalias 'tramp-compat-time-equal-p @@ -322,16 +281,38 @@ A nil value for either argument stands for the current time." (lambda (reporter &optional value _suffix) (progress-reporter-update reporter value)))) +;; `file-modes', `set-file-modes' and `set-file-times' got argument +;; FLAG in Emacs 28.1. +(defalias 'tramp-compat-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'file-modes) '(1 . 2)) + #'file-modes + (lambda (filename &optional _flag) + (file-modes filename)))) + +(defalias 'tramp-compat-set-file-modes + (if (equal (tramp-compat-funcall 'func-arity #'set-file-modes) '(2 . 3)) + #'set-file-modes + (lambda (filename mode &optional _flag) + (set-file-modes filename mode)))) + +(defalias 'tramp-compat-set-file-times + (if (equal (tramp-compat-funcall 'func-arity #'set-file-times) '(1 . 3)) + #'set-file-times + (lambda (filename &optional timestamp _flag) + (set-file-times filename timestamp)))) + (add-hook 'tramp-unload-hook (lambda () (unload-feature 'tramp-loaddefs 'force) (unload-feature 'tramp-compat 'force))) +(provide 'tramp-compat) + ;;; TODO: ;; -;; * Starting with Emacs 25.1, replace `tramp-message-show-message' by -;; the reverse of `inhibit-message'. - -(provide 'tramp-compat) +;; * `func-arity' exists since Emacs 26.1. +;; +;; * Starting with Emacs 27.1, there's no need to escape open +;; parentheses with a backslash in docstrings anymore. ;;; tramp-compat.el ends here diff --git a/lisp/net/tramp-crypt.el b/lisp/net/tramp-crypt.el new file mode 100644 index 00000000000..c9788fcff52 --- /dev/null +++ b/lisp/net/tramp-crypt.el @@ -0,0 +1,838 @@ +;;; tramp-crypt.el --- Tramp crypt utilities -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Michael Albinus <michael.albinus@gmx.de> +;; Keywords: comm, processes +;; Package: tramp + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Access functions for crypted remote files. It uses encfs to +;; encrypt / decrypt the files on a remote directory. A remote +;; directory, which shall include crypted files, must be declared in +;; `tramp-crypt-directories' via command `tramp-crypt-add-directory'. +;; All files in that directory, including all subdirectories, are +;; stored there encrypted. This includes file names and directory +;; names. + +;; This package is just responsible for the encryption part. Copying +;; of the crypted files is still the responsibility of the remote file +;; name handlers. + +;; A password protected encfs configuration file is created the very +;; first time you access a crypted remote directory. It is kept in +;; your user directory "~/.emacs.d/" with the url-encoded directory +;; name as part of the basename, and ".encfs6.xml" as suffix. Do not +;; loose this file and the corresponding password; otherwise there is +;; no way to decrypt your crypted files. + +;; If the user option `tramp-crypt-save-encfs-config-remote' is +;; non-nil (the default), the encfs configuration file ".encfs6.xml" +;; is also kept in the crypted remote directory. It depends on you, +;; whether you regard the password protection of this file as +;; sufficient. + +;; If you use a remote file name with a quoted localname part, this +;; localname and the corresponding file will not be encrypted/ +;; decrypted. For example, if you have a crypted remote directory +;; "/nextcloud:user@host:/crypted_dir", the command +;; +;; C-x d /nextcloud:user@host:/crypted_dir +;; +;; will show the directory listing with the plain file names, and the +;; command +;; +;; C-x d /nextcloud:user@host:/:/crypted_dir +;; +;; will show the directory with the encrypted file names, and visiting +;; a file will show its crypted contents. However, it is highly +;; discouraged to mix crypted and not crypted files in the same +;; directory. + +;; If a remote directory shall not include crypted files anymore, it +;; must be indicated by the command `tramp-crypt-remove-directory'. + +;;; Code: + +(eval-when-compile (require 'cl-lib)) +(require 'tramp) + +(autoload 'prop-match-beginning "text-property-search") +(autoload 'prop-match-end "text-property-search") +(autoload 'text-property-search-forward "text-property-search") + +(defconst tramp-crypt-method "crypt" + "Method name for crypted remote directories.") + +(defcustom tramp-crypt-encfs-program "encfs" + "Name of the encfs program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfsctl-program "encfsctl" + "Name of the encfsctl program." + :group 'tramp + :version "28.1" + :type 'string) + +(defcustom tramp-crypt-encfs-option "--standard" + "Configuration option for encfs. +This could be either \"--standard\" or \"--paranoia\". The file +name IV chaining mode mode will always be disabled when +initializing a new crypted remote directory." + :group 'tramp + :version "28.1" + :type '(choice (const "--standard") + (const "--paranoia"))) + +;; We check only for encfs, assuming that encfsctl will be available +;; as well. The autoloaded value is nil, the check will run when +;; tramp-crypt.el is loaded by `tramp-crypt-add-directory'. It is a +;; common technique to let-bind this variable to nil in order to +;; suppress the file name operation of this package. +;;;###tramp-autoload +(defvar tramp-crypt-enabled nil + "Non-nil when encryption support is available.") +(setq tramp-crypt-enabled (executable-find tramp-crypt-encfs-program)) + +;;;###tramp-autoload +(defconst tramp-crypt-encfs-config ".encfs6.xml" + "Encfs configuration file name.") + +(defcustom tramp-crypt-save-encfs-config-remote t + "Whether to keep the encfs configuration file in the crypted remote directory." + :group 'tramp + :version "28.1" + :type 'booleanp) + +;;;###tramp-autoload +(defvar tramp-crypt-directories nil + "List of crypted remote directories.") + +;; It must be a `defsubst' in order to push the whole code into +;; tramp-loaddefs.el. Otherwise, there would be recursive autoloading. +;;;###tramp-autoload +(defsubst tramp-crypt-file-name-p (name) + "Return the crypted remote directory NAME belongs to. +If NAME doesn't belong to a crypted remote directory, retun nil." + (catch 'crypt-file-name-p + (and tramp-crypt-enabled (stringp name) + (not (tramp-compat-file-name-quoted-p name)) + (not (string-suffix-p tramp-crypt-encfs-config name)) + (dolist (dir tramp-crypt-directories) + (and (string-prefix-p + dir (file-name-as-directory (expand-file-name name))) + (throw 'crypt-file-name-p dir)))))) + + +;; New handlers should be added here. +;;;###tramp-autoload +(defconst tramp-crypt-file-name-handler-alist + '((access-file . tramp-crypt-handle-access-file) + (add-name-to-file . tramp-handle-add-name-to-file) + ;; `byte-compiler-base-file-name' performed by default handler. + (copy-directory . tramp-handle-copy-directory) + (copy-file . tramp-crypt-handle-copy-file) + (delete-directory . tramp-crypt-handle-delete-directory) + (delete-file . tramp-crypt-handle-delete-file) + ;; `diff-latest-backup-file' performed by default handler. + ;; `directory-file-name' performed by default handler. + (directory-files . tramp-crypt-handle-directory-files) + (directory-files-and-attributes + . tramp-handle-directory-files-and-attributes) + (dired-compress-file . ignore) + (dired-uncache . tramp-handle-dired-uncache) + (exec-path . ignore) + ;; `expand-file-name' performed by default handler. + (file-accessible-directory-p . tramp-handle-file-accessible-directory-p) + (file-acl . ignore) + (file-attributes . tramp-crypt-handle-file-attributes) + (file-directory-p . tramp-handle-file-directory-p) + (file-equal-p . tramp-handle-file-equal-p) + (file-executable-p . tramp-crypt-handle-file-executable-p) + (file-exists-p . tramp-handle-file-exists-p) + (file-in-directory-p . tramp-handle-file-in-directory-p) + (file-local-copy . tramp-handle-file-local-copy) + (file-modes . tramp-handle-file-modes) + (file-name-all-completions . tramp-crypt-handle-file-name-all-completions) + ;; `file-name-as-directory' performed by default handler. + (file-name-case-insensitive-p . ignore) + (file-name-completion . tramp-handle-file-name-completion) + ;; `file-name-directory' performed by default handler. + ;; `file-name-nondirectory' performed by default handler. + ;; `file-name-sans-versions' performed by default handler. + (file-newer-than-file-p . tramp-handle-file-newer-than-file-p) + (file-notify-add-watch . ignore) + (file-notify-rm-watch . ignore) + (file-notify-valid-p . ignore) + (file-ownership-preserved-p . tramp-crypt-handle-file-ownership-preserved-p) + (file-readable-p . tramp-crypt-handle-file-readable-p) + (file-regular-p . tramp-handle-file-regular-p) + ;; `file-remote-p' performed by default handler. + (file-selinux-context . ignore) + (file-symlink-p . tramp-handle-file-symlink-p) + (file-system-info . tramp-crypt-handle-file-system-info) + ;; `file-truename' performed by default handler. + (file-writable-p . tramp-crypt-handle-file-writable-p) + (find-backup-file-name . tramp-handle-find-backup-file-name) + ;; `get-file-buffer' performed by default handler. + (insert-directory . tramp-crypt-handle-insert-directory) + ;; `insert-file-contents' performed by default handler. + (load . tramp-handle-load) + (make-auto-save-file-name . tramp-handle-make-auto-save-file-name) + (make-directory . tramp-crypt-handle-make-directory) + (make-directory-internal . ignore) + (make-nearby-temp-file . tramp-handle-make-nearby-temp-file) + (make-process . ignore) + (make-symbolic-link . tramp-handle-make-symbolic-link) + (process-file . ignore) + (rename-file . tramp-crypt-handle-rename-file) + (set-file-acl . ignore) + (set-file-modes . tramp-crypt-handle-set-file-modes) + (set-file-selinux-context . ignore) + (set-file-times . tramp-crypt-handle-set-file-times) + (set-visited-file-modtime . tramp-handle-set-visited-file-modtime) + (shell-command . ignore) + (start-file-process . ignore) + ;; `substitute-in-file-name' performed by default handler. + (temporary-file-directory . tramp-handle-temporary-file-directory) + ;; `tramp-get-remote-gid' performed by default handler. + ;; `tramp-get-remote-uid' performed by default handler. + (tramp-set-file-uid-gid . tramp-crypt-handle-set-file-uid-gid) + (unhandled-file-name-directory . ignore) + (vc-registered . ignore) + (verify-visited-file-modtime . tramp-handle-verify-visited-file-modtime) + (write-region . tramp-handle-write-region)) + "Alist of handler functions for crypt method. +Operations not mentioned here will be handled by the default Emacs primitives.") + +(defsubst tramp-crypt-file-name-for-operation (operation &rest args) + "Like `tramp-file-name-for-operation', but for crypted remote files." + (let ((tfnfo (apply #'tramp-file-name-for-operation operation args))) + ;; `tramp-file-name-for-operation' returns already the first argument + ;; if it is remote. So we check a possible second argument. + (unless (tramp-crypt-file-name-p tfnfo) + (setq tfnfo (apply + #'tramp-file-name-for-operation operation + (cons (tramp-compat-temporary-file-directory) (cdr args))))) + tfnfo)) + +(defun tramp-crypt-run-real-handler (operation args) + "Invoke normal file name handler for OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (let* ((inhibit-file-name-handlers + `(tramp-crypt-file-name-handler + . + ,(and (eq inhibit-file-name-operation operation) + inhibit-file-name-handlers))) + (inhibit-file-name-operation operation)) + (apply operation args))) + +;;;###tramp-autoload +(defun tramp-crypt-file-name-handler (operation &rest args) + "Invoke the crypted remote file related OPERATION. +First arg specifies the OPERATION, second arg ARGS is a list of +arguments to pass to the OPERATION." + (if-let ((filename + (apply #'tramp-crypt-file-name-for-operation operation args)) + (fn (and (tramp-crypt-file-name-p filename) + (assoc operation tramp-crypt-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-crypt-run-real-handler operation args))) + +;;;###tramp-autoload +(progn (defun tramp-register-crypt-file-name-handler () + "Add crypt file name handler to `file-name-handler-alist'." + (when (and tramp-crypt-enabled tramp-crypt-directories) + (add-to-list 'file-name-handler-alist + (cons tramp-file-name-regexp #'tramp-crypt-file-name-handler)) + (put #'tramp-crypt-file-name-handler 'safe-magic t)))) + +(tramp-register-file-name-handlers) + +;; Mark `operations' the handler is responsible for. +(put #'tramp-crypt-file-name-handler 'operations + (mapcar #'car tramp-crypt-file-name-handler-alist)) + + +;; File name conversions. + +(defun tramp-crypt-config-file-name (vec) + "Return the encfs config file name for VEC." + (expand-file-name + (concat "tramp-" (tramp-file-name-host vec) tramp-crypt-encfs-config) + user-emacs-directory)) + +(defun tramp-crypt-maybe-open-connection (vec) + "Maybe open a connection VEC. +Does not do anything if a connection is already open, but re-opens the +connection if a previous connection has died for some reason." + ;; For password handling, we need a process bound to the connection + ;; buffer. Therefore, we create a dummy process. Maybe there is a + ;; better solution? + (unless (get-buffer-process (tramp-get-connection-buffer vec)) + (let ((p (make-network-process + :name (tramp-get-connection-name vec) + :buffer (tramp-get-connection-buffer vec) + :server t :host 'local :service t :noquery t))) + (process-put p 'vector vec) + (set-process-query-on-exit-flag p nil))) + + ;; The following operations must be performed w/o + ;; `tramp-crypt-file-name-handler'. + (let* (tramp-crypt-enabled + ;; Don't check for a proper method. + (non-essential t) + (remote-config + (expand-file-name + tramp-crypt-encfs-config (tramp-crypt-get-remote-dir vec))) + (local-config (tramp-crypt-config-file-name vec))) + ;; There is no local encfs6 config file. + (when (not (file-exists-p local-config)) + (if (and tramp-crypt-save-encfs-config-remote + (file-exists-p remote-config)) + ;; Copy remote encfs6 config file if possible. + (copy-file remote-config local-config 'ok 'keep) + + ;; Create local encfs6 config file otherwise. + (let* ((default-directory (tramp-compat-temporary-file-directory)) + (tmpdir1 (file-name-as-directory + (tramp-compat-make-temp-file " .crypt" 'dir-flag))) + (tmpdir2 (file-name-as-directory + (tramp-compat-make-temp-file " .nocrypt" 'dir-flag)))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (with-temp-buffer + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format + "New EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when + (zerop + (tramp-call-process-region + vec (point-min) (point-max) + tramp-crypt-encfs-program nil (tramp-get-connection-buffer vec) + nil tramp-crypt-encfs-option "--extpass=cat" tmpdir1 tmpdir2)) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))))) + + ;; Write local config file. Suppress file name IV chaining mode. + (with-temp-file local-config + (insert-file-contents + (expand-file-name tramp-crypt-encfs-config tmpdir1)) + (when (search-forward + "<chainedNameIV>1</chainedNameIV>" nil 'noerror) + (replace-match "<chainedNameIV>0</chainedNameIV>"))) + + ;; Unmount encfs. Delete temporary directories. + (tramp-call-process + vec tramp-crypt-encfs-program nil nil nil + "--unmount" tmpdir1 tmpdir2) + (delete-directory tmpdir1 'recursive) + (delete-directory tmpdir2) + + ;; Copy local encfs6 config file to remote. + (when tramp-crypt-save-encfs-config-remote + (copy-file local-config remote-config 'ok 'keep))))))) + +(defun tramp-crypt-send-command (vec &rest args) + "Send encfsctl command to connection VEC. +ARGS are the arguments. It returns t if ran successful, and nil otherwise." + (tramp-crypt-maybe-open-connection vec) + (with-current-buffer (tramp-get-connection-buffer vec) + (erase-buffer) + (set-buffer-multibyte nil)) + (with-temp-buffer + (let* (;; Don't check for a proper method. + (non-essential t) + (default-directory (tramp-compat-temporary-file-directory)) + ;; We cannot add it to `process-environment', because + ;; `tramp-call-process-region' doesn't use it. + (encfs-config + (format "ENCFS6_CONFIG=%s" (tramp-crypt-config-file-name vec))) + (args (delq nil args))) + ;; Enable `auth-source', unless "emacs -Q" has been called. + (tramp-set-connection-property + vec "first-password-request" tramp-cache-read-persistent-data) + (insert + (tramp-read-passwd + (tramp-get-connection-process vec) + (format "EncFS Password for %s " (tramp-crypt-get-remote-dir vec)))) + (when (zerop + (apply + #'tramp-call-process-region vec (point-min) (point-max) + "env" nil (tramp-get-connection-buffer vec) + nil encfs-config tramp-crypt-encfsctl-program + (car args) "--extpass=cat" (cdr args))) + ;; Save the password. + (ignore-errors + (and (functionp tramp-password-save-function) + (funcall tramp-password-save-function))) + t)))) + +(defun tramp-crypt-do-encrypt-or-decrypt-file-name (op name) + "Return encrypted / decrypted NAME if NAME belongs to a crypted directory. +OP must be `encrypt' or `decrypt'. Raise an error if this fails. +Otherwise, return NAME." + (if-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p name)) + ;; It must be absolute for the cache. + (localname (substring name (1- (length dir)))) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + ;; Preserve trailing "/". + (funcall + (if (directory-name-p name) #'file-name-as-directory #'identity) + (concat + dir + (unless (string-equal localname "/") + (with-tramp-file-property + crypt-vec localname (concat (symbol-name op) "-file-name") + (unless (tramp-crypt-send-command + crypt-vec (if (eq op 'encrypt) "encode" "decode") + (tramp-compat-temporary-file-directory) localname) + (tramp-error + crypt-vec 'file-error "%s of file name %s failed." + (if (eq op 'encrypt) "Encoding" "Decoding") name)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (goto-char (point-min)) + (buffer-substring (point-min) (point-at-eol))))))) + ;; Nothing to do. + name)) + +(defsubst tramp-crypt-encrypt-file-name (name) + "Return encrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'encrypt name)) + +(defsubst tramp-crypt-decrypt-file-name (name) + "Return decrypted NAME if NAME belongs to a crypted directory. +Otherwise, return NAME." + (tramp-crypt-do-encrypt-or-decrypt-file-name 'decrypt name)) + +(defun tramp-crypt-do-encrypt-or-decrypt-file (op root infile outfile) + "Encrypt / decrypt file INFILE to OUTFILE according to crypted directory ROOT. +Both files must be local files. OP must be `encrypt' or `decrypt'. +If OP ist `decrypt', the basename of INFILE must be an encrypted file name. +Raise an error if this fails." + (when-let ((tramp-crypt-enabled t) + (dir (tramp-crypt-file-name-p root)) + (crypt-vec (tramp-crypt-dissect-file-name dir))) + (let ((coding-system-for-read + (if (eq op 'decrypt) 'binary coding-system-for-read)) + (coding-system-for-write + (if (eq op 'encrypt) 'binary coding-system-for-write))) + (unless (tramp-crypt-send-command + crypt-vec "cat" (and (eq op 'encrypt) "--reverse") + (file-name-directory infile) + (concat "/" (file-name-nondirectory infile))) + (tramp-error + crypt-vec 'file-error "%s of file %s failed." + (if (eq op 'encrypt) "Encrypting" "Decrypting") infile)) + (with-current-buffer (tramp-get-connection-buffer crypt-vec) + (write-region nil nil outfile))))) + +(defsubst tramp-crypt-encrypt-file (root infile outfile) + "Encrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'encrypt root infile outfile)) + +(defsubst tramp-crypt-decrypt-file (root infile outfile) + "Decrypt file INFILE to OUTFILE according to crypted directory ROOT. +See `tramp-crypt-do-encrypt-or-decrypt-file'." + (tramp-crypt-do-encrypt-or-decrypt-file 'decrypt root infile outfile)) + +;;;###tramp-autoload +(defun tramp-crypt-add-directory (name) + "Mark remote directory NAME for encryption. +Files in that directory and all subdirectories will be encrypted +before copying to, and decrypted after copying from that +directory. File names will be also encrypted." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (unless (and (tramp-tramp-file-p name) (file-directory-p name)) + (tramp-user-error nil "%s must be an existing remote directory." name)) + (when (tramp-compat-file-name-quoted-p name) + (tramp-user-error nil "%s must not be quoted." name)) + (setq name (file-name-as-directory (expand-file-name name))) + (unless (member name tramp-crypt-directories) + (setq tramp-crypt-directories (cons name tramp-crypt-directories))) + (tramp-register-file-name-handlers)) + +(defun tramp-crypt-remove-directory (name) + "Unmark remote directory NAME for encryption. +Existing files in that directory and its subdirectories will be +kept in their encrypted form." + (interactive "DRemote directory name: ") + (unless tramp-crypt-enabled + (tramp-user-error nil "Feature is not enabled.")) + (setq name (file-name-as-directory (expand-file-name name))) + (when (and (member name tramp-crypt-directories) + (delete + tramp-crypt-encfs-config + (directory-files name nil directory-files-no-dot-files-regexp)) + (yes-or-no-p + "There exist encrypted files, do you want to continue? ")) + (setq tramp-crypt-directories (delete name tramp-crypt-directories)) + (tramp-register-file-name-handlers))) + +;; `auth-source' requires a user. +(defun tramp-crypt-dissect-file-name (name) + "Return a `tramp-file-name' structure for NAME. +The structure consists of the `tramp-crypt-method' method, the +local user name, the hexlified directory NAME as host, and the +localname." + (save-match-data + (if-let ((dir (tramp-crypt-file-name-p name))) + (make-tramp-file-name + :method tramp-crypt-method :user (user-login-name) + :host (url-hexify-string dir)) + (tramp-user-error nil "Not a crypted remote directory: \"%s\"" name)))) + +(defun tramp-crypt-get-remote-dir (vec) + "Return the name of the crypted remote directory to be used for encfs." + (url-unhex-string (tramp-file-name-host vec))) + + +;; File name primitives. + +(defun tramp-crypt-handle-access-file (filename string) + "Like `access-file' for Tramp files." + (let* ((encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-regexp (concat (regexp-quote encrypt-filename) "\\'")) + tramp-crypt-enabled) + (condition-case err + (access-file encrypt-filename string) + (error + (when (and (eq (car err) 'file-missing) (stringp (cadr err)) + (string-match-p encrypt-regexp (cadr err))) + (setcar + (cdr err) + (replace-regexp-in-string encrypt-regexp filename (cadr err)))) + (signal (car err) (cdr err)))))) + +(defun tramp-crypt-do-copy-or-rename-file + (op filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Copy or rename a remote file. +OP must be `copy' or `rename' and indicates the operation to perform. +FILENAME specifies the file to copy or rename, NEWNAME is the name of +the new file (for copy) or the new name of the file (for rename). +OK-IF-ALREADY-EXISTS means don't barf if NEWNAME exists already. +KEEP-DATE means to make sure that NEWNAME has the same timestamp +as FILENAME. PRESERVE-UID-GID, when non-nil, instructs to keep +the uid and gid if both files are on the same host. +PRESERVE-EXTENDED-ATTRIBUTES is ignored. + +This function is invoked by `tramp-crypt-handle-copy-file' and +`tramp-crypt-handle-rename-file'. It is an error if OP is +neither of `copy' and `rename'. FILENAME and NEWNAME must be +absolute file names." + (unless (memq op '(copy rename)) + (error "Unknown operation `%s', must be `copy' or `rename'" op)) + + (setq filename (file-truename filename)) + (let ((t1 (tramp-crypt-file-name-p filename)) + (t2 (tramp-crypt-file-name-p newname)) + (encrypt-filename (tramp-crypt-encrypt-file-name filename)) + (encrypt-newname (tramp-crypt-encrypt-file-name newname)) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + + (if (file-directory-p filename) + (progn + (copy-directory filename newname keep-date t) + (when (eq op 'rename) + (delete-directory filename 'recursive))) + + (with-parsed-tramp-file-name (if t1 filename newname) nil + (unless (file-exists-p filename) + (tramp-error + v tramp-file-missing + "%s file" msg-operation "No such file or directory" filename)) + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) + (when (and (file-directory-p newname) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) + + (with-tramp-progress-reporter + v 0 (format "%s %s to %s" msg-operation filename newname) + (if (and t1 t2 (string-equal t1 t2)) + ;; Both files are on the same crypted remote directory. + (let (tramp-crypt-enabled) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + + (let* ((tmpdir (tramp-compat-make-temp-file filename 'dir)) + (tmpfile1 + (expand-file-name + (file-name-nondirectory encrypt-filename) tmpdir)) + (tmpfile2 + (expand-file-name + (file-name-nondirectory encrypt-newname) tmpdir)) + tramp-crypt-enabled) + (cond + ;; Source and target file are on a crypted remote directory. + ((and t1 t2) + (if (eq op 'copy) + (copy-file + encrypt-filename encrypt-newname ok-if-already-exists + keep-date preserve-uid-gid preserve-extended-attributes) + (rename-file + encrypt-filename encrypt-newname ok-if-already-exists))) + ;; Source file is on a crypted remote directory. + (t1 + (if (eq op 'copy) + (copy-file + encrypt-filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file encrypt-filename tmpfile1 t)) + (tramp-crypt-decrypt-file t1 tmpfile1 tmpfile2) + (rename-file tmpfile2 newname ok-if-already-exists)) + ;; Target file is on a crypted remote directory. + (t2 + (if (eq op 'copy) + (copy-file + filename tmpfile1 t keep-date preserve-uid-gid + preserve-extended-attributes) + (rename-file filename tmpfile1 t)) + (tramp-crypt-encrypt-file t2 tmpfile1 tmpfile2) + (rename-file tmpfile2 encrypt-newname ok-if-already-exists))) + (delete-directory tmpdir 'recursive)))))) + + (when (and t1 (eq op 'rename)) + (with-parsed-tramp-file-name filename v1 + (tramp-flush-file-properties v1 v1-localname))) + + (when t2 + (with-parsed-tramp-file-name newname v2 + (tramp-flush-file-properties v2 v2-localname))))) + +(defun tramp-crypt-handle-copy-file + (filename newname &optional ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + "Like `copy-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'copy filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes) + (tramp-run-real-handler + #'copy-file + (list filename newname ok-if-already-exists keep-date + preserve-uid-gid preserve-extended-attributes)))) + +(defun tramp-crypt-handle-delete-directory + (directory &optional recursive trash) + "Like `delete-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name directory) nil + (tramp-flush-directory-properties v localname) + (let (tramp-crypt-enabled) + (delete-directory + (tramp-crypt-encrypt-file-name directory) recursive trash)))) + +(defun tramp-crypt-handle-delete-file (filename &optional trash) + "Like `delete-file' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name filename) nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (delete-file (tramp-crypt-encrypt-file-name filename) trash)))) + +(defun tramp-crypt-handle-directory-files (directory &optional full match nosort) + "Like `directory-files' for Tramp files." + (unless (file-exists-p directory) + (tramp-error + (tramp-dissect-file-name directory) tramp-file-missing + "No such file or directory" directory)) + (when (file-directory-p directory) + (setq directory (file-name-as-directory (expand-file-name directory))) + (let* (tramp-crypt-enabled + (result + (directory-files (tramp-crypt-encrypt-file-name directory) 'full))) + (setq result + (mapcar (lambda (x) (tramp-crypt-decrypt-file-name x)) result)) + (when match + (setq result + (delq + nil + (mapcar + (lambda (x) + (when (string-match-p match (substring x (length directory))) + x)) + result)))) + (unless full + (setq result + (mapcar + (lambda (x) + (replace-regexp-in-string + (concat "^" (regexp-quote directory)) "" x)) + result))) + (if nosort result (sort result #'string<))))) + +(defun tramp-crypt-handle-file-attributes (filename &optional id-format) + "Like `file-attributes' for Tramp files." + (let (tramp-crypt-enabled) + (file-attributes (tramp-crypt-encrypt-file-name filename) id-format))) + +(defun tramp-crypt-handle-file-executable-p (filename) + "Like `file-executable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-executable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-name-all-completions (filename directory) + "Like `file-name-all-completions' for Tramp files." + (all-completions + filename + (let* (completion-regexp-list + tramp-crypt-enabled + (directory (file-name-as-directory directory)) + (enc-dir (tramp-crypt-encrypt-file-name directory))) + (mapcar + (lambda (x) + (substring + (tramp-crypt-decrypt-file-name (concat enc-dir x)) + (length directory))) + (file-name-all-completions "" enc-dir))))) + +(defun tramp-crypt-handle-file-readable-p (filename) + "Like `file-readable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-readable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-ownership-preserved-p (filename &optional group) + "Like `file-ownership-preserved-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-ownership-preserved-p (tramp-crypt-encrypt-file-name filename) group))) + +(defun tramp-crypt-handle-file-system-info (filename) + "Like `file-system-info' for Tramp files." + (let (tramp-crypt-enabled) + ;; `file-system-info' exists since Emacs 27.1. + (tramp-compat-funcall + 'file-system-info (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-file-writable-p (filename) + "Like `file-writable-p' for Tramp files." + (let (tramp-crypt-enabled) + (file-writable-p (tramp-crypt-encrypt-file-name filename)))) + +(defun tramp-crypt-handle-insert-directory + (filename switches &optional wildcard full-directory-p) + "Like `insert-directory' for Tramp files. +WILDCARD is not supported." + ;; This package has been added to Emacs 27.1. + (when (load "text-property-search" 'noerror 'nomessage) + (let (tramp-crypt-enabled) + (tramp-handle-insert-directory + (tramp-crypt-encrypt-file-name filename) + switches wildcard full-directory-p) + (let* ((filename (file-name-as-directory filename)) + (enc (tramp-crypt-encrypt-file-name filename)) + match string) + (goto-char (point-min)) + (while (setq match (text-property-search-forward 'dired-filename t t)) + (setq string + (buffer-substring + (prop-match-beginning match) (prop-match-end match)) + string (if (file-name-absolute-p string) + (tramp-crypt-decrypt-file-name string) + (substring + (tramp-crypt-decrypt-file-name (concat enc string)) + (length filename)))) + (delete-region (prop-match-beginning match) (prop-match-end match)) + (insert (propertize string 'dired-filename t))))))) + +(defun tramp-crypt-handle-make-directory (dir &optional parents) + "Like `make-directory' for Tramp files." + (with-parsed-tramp-file-name (expand-file-name dir) nil + (when (and (null parents) (file-exists-p dir)) + (tramp-error v 'file-already-exists "Directory already exists %s" dir)) + (let (tramp-crypt-enabled) + (make-directory (tramp-crypt-encrypt-file-name dir) parents)) + ;; When PARENTS is non-nil, DIR could be a chain of non-existent + ;; directories a/b/c/... Instead of checking, we simply flush the + ;; whole cache. + (tramp-flush-directory-properties + v (if parents "/" (file-name-directory localname))))) + +(defun tramp-crypt-handle-rename-file + (filename newname &optional ok-if-already-exists) + "Like `rename-file' for Tramp files." + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) + ;; At least one file a Tramp file? + (if (or (tramp-tramp-file-p filename) + (tramp-tramp-file-p newname)) + (tramp-crypt-do-copy-or-rename-file + 'rename filename newname ok-if-already-exists + 'keep-date 'preserve-uid-gid) + (tramp-run-real-handler + #'rename-file (list filename newname ok-if-already-exists)))) + +(defun tramp-crypt-handle-set-file-modes (filename mode &optional flag) + "Like `set-file-modes' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-modes + (tramp-crypt-encrypt-file-name filename) mode flag)))) + +(defun tramp-crypt-handle-set-file-times (filename &optional time flag) + "Like `set-file-times' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-compat-set-file-times + (tramp-crypt-encrypt-file-name filename) time flag)))) + +(defun tramp-crypt-handle-set-file-uid-gid (filename &optional uid gid) + "Like `tramp-set-file-uid-gid' for Tramp files." + (with-parsed-tramp-file-name filename nil + (tramp-flush-file-properties v localname) + (let (tramp-crypt-enabled) + (tramp-set-file-uid-gid + (tramp-crypt-encrypt-file-name filename) uid gid)))) + +(add-hook 'tramp-unload-hook + (lambda () + (unload-feature 'tramp-crypt 'force))) + +(provide 'tramp-crypt) + +;;; TODO: + +;; * I suggest having a feature where the user can specify to always +;; use encryption for certain host names. So if you specify a host +;; name which is on that list (of names, or perhaps regexps?), tramp +;; would modify the request so as to do the encryption. (Richard Stallman) + +;;; tramp-crypt.el ends here diff --git a/lisp/net/tramp-ftp.el b/lisp/net/tramp-ftp.el index 95ae1569dc9..996a92454f1 100644 --- a/lisp/net/tramp-ftp.el +++ b/lisp/net/tramp-ftp.el @@ -31,8 +31,7 @@ (require 'tramp) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (defvar ange-ftp-ftp-name-arg) (defvar ange-ftp-ftp-name-res) (defvar ange-ftp-name-format) @@ -79,9 +78,9 @@ present for backward compatibility." ;;; This regexp recognizes absolute filenames with only one component ;;; on Windows, for the sake of hostname completion. (and (memq system-type '(ms-dos windows-nt)) - (or (assoc "^[a-zA-Z]:/[^/:]*\\'" file-name-handler-alist) + (or (assoc "^[[:alpha:]]:/[^/:]*\\'" file-name-handler-alist) (setq file-name-handler-alist - (cons '("^[a-zA-Z]:/[^/:]*\\'" . + (cons '("^[:alpha:]]:/[^/:]*\\'" . ange-ftp-completion-hook-function) file-name-handler-alist))))) diff --git a/lisp/net/tramp-gvfs.el b/lisp/net/tramp-gvfs.el index 34a234c47f0..6467d8f88b4 100644 --- a/lisp/net/tramp-gvfs.el +++ b/lisp/net/tramp-gvfs.el @@ -49,11 +49,15 @@ ;; The user option `tramp-gvfs-methods' contains the list of supported ;; connection methods. Per default, these are "afp", "dav", "davs", -;; "gdrive", "nextcloud" and "sftp". +;; "gdrive", "media", "nextcloud" and "sftp". ;; "gdrive" and "nextcloud" connection methods require a respective ;; account in GNOME Online Accounts, with enabled "Files" service. +;; The "media" connection method is responsible for media devices, +;; like cell phones, tablets, cameras etc. The device must already be +;; connected via USB, before accessing it. + ;; Other possible connection methods are "ftp", "http", "https" and ;; "smb". When one of these methods is added to the list, the remote ;; access for that method is performed via GVFS instead of the native @@ -104,8 +108,7 @@ (require 'url-util) ;; Pacify byte-compiler. -(eval-when-compile - (require 'custom)) +(eval-when-compile (require 'custom)) (declare-function zeroconf-init "zeroconf") (declare-function zeroconf-list-service-types "zeroconf") @@ -121,16 +124,19 @@ (autoload 'zeroconf-init "zeroconf") (tramp-compat-funcall 'dbus-get-unique-name :system) (tramp-compat-funcall 'dbus-get-unique-name :session) - (or (tramp-compat-process-running-p "gvfs-fuse-daemon") - (tramp-compat-process-running-p "gvfsd-fuse")))) + (or ;; Until Emacs 25, `process-attributes' could crash Emacs + ;; for some processes. Better we don't check. + (<= emacs-major-version 25) + (tramp-process-running-p "gvfs-fuse-daemon") + (tramp-process-running-p "gvfsd-fuse")))) "Non-nil when GVFS is available.") ;;;###tramp-autoload (defcustom tramp-gvfs-methods - '("afp" "dav" "davs" "gdrive" "nextcloud" "sftp") + '("afp" "dav" "davs" "gdrive" "media" "nextcloud" "sftp") "List of methods for remote files, accessed with GVFS." :group 'tramp - :version "27.1" + :version "28.1" :type '(repeat (choice (const "afp") (const "dav") (const "davs") @@ -138,10 +144,12 @@ (const "gdrive") (const "http") (const "https") + (const "media") (const "nextcloud") (const "sftp") (const "smb")))) +;;;###tramp-autoload (defconst tramp-goa-methods '("gdrive" "nextcloud") "List of methods which require registration at GNOME Online Accounts.") @@ -151,15 +159,23 @@ (dolist (method tramp-goa-methods) (setq tramp-gvfs-methods (delete method tramp-gvfs-methods)))) -;; Add defaults for `tramp-default-user-alist' and `tramp-default-host-alist'. ;;;###tramp-autoload -(tramp--with-startup - (when (string-match "\\(.+\\)@\\(\\(?:gmail\\|googlemail\\)\\.com\\)" - user-mail-address) - (add-to-list 'tramp-default-user-alist - `("\\`gdrive\\'" nil ,(match-string 1 user-mail-address))) - (add-to-list 'tramp-default-host-alist - '("\\`gdrive\\'" nil ,(match-string 2 user-mail-address))))) +(defvar tramp-media-methods '("afc" "gphoto2" "mtp") + "List of GVFS methods which are covered by the \"media\" method. +They are checked during start up via +`tramp-gvfs-interface-remotevolumemonitor'.") + +(defsubst tramp-gvfs-service-volumemonitor (method) + "Return the well known name of the volume monitor responsible for METHOD." + (symbol-value + (intern-soft (format "tramp-gvfs-service-%s-volumemonitor" method)))) + +;; Remove media methods if not supported. +(when tramp-gvfs-enabled + (dolist (method tramp-media-methods) + (unless (member (tramp-gvfs-service-volumemonitor method) + (dbus-list-known-names :session)) + (setq tramp-media-methods (delete method tramp-media-methods))))) ;;;###tramp-autoload (defcustom tramp-gvfs-zeroconf-domain "local" @@ -169,13 +185,15 @@ :type 'string) ;; Add the methods to `tramp-methods', in order to allow minibuffer -;; completion. +;; completion. Add defaults for `tramp-default-host-alist'. ;;;###tramp-autoload (when (featurep 'dbusbind) (tramp--with-startup - (dolist (elt tramp-gvfs-methods) - (unless (assoc elt tramp-methods) - (add-to-list 'tramp-methods (cons elt nil)))))) + (dolist (method tramp-gvfs-methods) + (unless (assoc method tramp-methods) + (add-to-list 'tramp-methods `(,method))) + (when (member method tramp-goa-methods) + (add-to-list 'tramp-default-host-alist `(,method nil "")))))) (defconst tramp-gvfs-path-tramp (concat dbus-path-emacs "/Tramp") "The preceding object path for own objects.") @@ -457,8 +475,209 @@ It has been changed in GVFS 1.14.") ;; </interface> ;; The basic structure for GNOME Online Accounts. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. -(cl-defstruct (tramp-goa-name (:type list) :named) method user host port) +;; in order to be compatible with Emacs 25. +(cl-defstruct (tramp-goa-account (:type list) :named) method user host port) + +;;;###tramp-autoload +(defconst tramp-gvfs-service-afc-volumemonitor "org.gtk.vfs.AfcVolumeMonitor" + "The well known name of the AFC volume monitor.") + +;; This one is not needed yet. +(defconst tramp-gvfs-service-goa-volumemonitor "org.gtk.vfs.GoaVolumeMonitor" + "The well known name of the GOA volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-gphoto2-volumemonitor + "org.gtk.vfs.GPhoto2VolumeMonitor" + "The well known name of the GPhoto2 volume monitor.") + +;;;###tramp-autoload +(defconst tramp-gvfs-service-mtp-volumemonitor "org.gtk.vfs.MTPVolumeMonitor" + "The well known name of the MTP volume monitor.") + +(defconst tramp-gvfs-path-remotevolumemonitor + "/org/gtk/Private/RemoteVolumeMonitor" + "The object path of the remote volume monitor.") + +(defconst tramp-gvfs-interface-remotevolumemonitor + "org.gtk.Private.RemoteVolumeMonitor" + "The volume monitor interface.") + +;; <interface name='org.gtk.Private.RemoteVolumeMonitor'> +;; <method name="IsSupported"> +;; <arg type='b' name='is_supported' direction='out'/> +;; </method> +;; <method name="List"> +;; <arg type='a(ssssbbbbbbbbuasa{ss}sa{sv})' name='drives' direction='out'/> +;; <arg type='a(ssssssbbssa{ss}sa{sv})' name='volumes' direction='out'/> +;; <arg type='a(ssssssbsassa{sv})' name='mounts' direction='out'/> +;; </method> +;; <method name="CancelOperation"> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='b' name='was_cancelled' direction='out'/> +;; </method> +;; <method name="MountUnmount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="VolumeMount"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='mount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveEject"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DrivePollForMedia"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; </method> +;; <method name="DriveStart"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="DriveStop"> +;; <arg type='s' name='id' direction='in'/> +;; <arg type='s' name='cancellation_id' direction='in'/> +;; <arg type='u' name='unmount_flags' direction='in'/> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; </method> +;; <method name="MountOpReply"> +;; <arg type='s' name='mount_op_id' direction='in'/> +;; <arg type='i' name='result' direction='in'/> +;; <arg type='s' name='user_name' direction='in'/> +;; <arg type='s' name='domain' direction='in'/> +;; <arg type='s' name='encoded_password' direction='in'/> +;; <arg type='i' name='password_save' direction='in'/> +;; <arg type='i' name='choice' direction='in'/> +;; <arg type='b' name='anonymous' direction='in'/> +;; </method> +;; <signal name="DriveChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveConnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveDisconnected"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveEjectButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="DriveStopButton"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssbbbbbbbbuasa{ss}sa{sv})' name='drive'/> +;; </signal> +;; <signal name="VolumeChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="VolumeRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbbssa{ss}sa{sv})' name='volume'/> +;; </signal> +;; <signal name="MountChanged"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountAdded"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountPreUnmount"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountRemoved"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='(ssssssbsassa{sv})' name='mount'/> +;; </signal> +;; <signal name="MountOpAskPassword"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='s' name='default_user'/> +;; <arg type='s' name='default_domain'/> +;; <arg type='u' name='flags'/> +;; </signal> +;; <signal name="MountOpAskQuestion"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowProcesses"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='ai' name='pid'/> +;; <arg type='as' name='choices'/> +;; </signal> +;; <signal name="MountOpShowUnmountProgress"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; <arg type='s' name='message_to_show'/> +;; <arg type='x' name='time_left'/> +;; <arg type='x' name='bytes_left'/> +;; </signal> +;; <signal name="MountOpAborted"> +;; <arg type='s' name='dbus_name'/> +;; <arg type='s' name='id'/> +;; </signal> +;; </interface> + +;; STRUCT volume +;; STRING id +;; STRING name +;; STRING gicon_data +;; STRING symbolic_gicon_data +;; STRING uuid +;; STRING activation_uri +;; BOOLEAN can-mount +;; BOOLEAN should-automount +;; STRING drive-id +;; STRING mount-id +;; ARRAY identifiers +;; DICT +;; STRING key (unix-device, class, uuid, ...) +;; STRING value +;; STRING sort_key +;; ARRAY expansion +;; DICT +;; STRING key (always-call-mount, is-removable, ...) +;; VARIANT value (boolean?) + +;; The basic structure for media devices. We use a list :type, in +;; order to be compatible with Emacs 25. +(cl-defstruct (tramp-media-device (:type list) :named) method host port) ;; "gvfs-<command>" utilities have been deprecated in GVFS 1.31.1. We ;; must use "gio <command>" tool instead. @@ -470,38 +689,41 @@ It has been changed in GVFS 1.14.") ("gvfs-monitor-file" . "monitor") ("gvfs-mount" . "mount") ("gvfs-move" . "move") + ("gvfs-rename" . "rename") ("gvfs-rm" . "remove") ("gvfs-set-attribute" . "set") ("gvfs-trash" . "trash")) "List of cons cells, mapping \"gvfs-<command>\" to \"gio <command>\".") ;; <http://www.pygtk.org/docs/pygobject/gio-constants.html> -(defconst tramp-gvfs-file-attributes - '("name" - "type" - "standard::display-name" - "standard::symlink-target" - "standard::is-volatile" - "unix::nlink" - "unix::uid" - "owner::user" - "unix::gid" - "owner::group" - "time::access" - "time::modified" - "time::changed" - "standard::size" - "unix::mode" - "access::can-read" - "access::can-write" - "access::can-execute" - "unix::inode" - "unix::device") - "GVFS file attributes.") - -(defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp - (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") - "Regexp to parse GVFS file attributes with `gvfs-ls'.") +(eval-and-compile + (defconst tramp-gvfs-file-attributes + '("name" + "type" + "standard::display-name" + "standard::symlink-target" + "standard::is-volatile" + "unix::nlink" + "unix::uid" + "owner::user" + "unix::gid" + "owner::group" + "time::access" + "time::modified" + "time::changed" + "standard::size" + "unix::mode" + "access::can-read" + "access::can-write" + "access::can-execute" + "unix::inode" + "unix::device") + "GVFS file attributes.")) + +(eval-and-compile + (defconst tramp-gvfs-file-attributes-with-gvfs-ls-regexp + (concat "[[:blank:]]" (regexp-opt tramp-gvfs-file-attributes t) "=\\(.+?\\)") + "Regexp to parse GVFS file attributes with `gvfs-ls'.")) (defconst tramp-gvfs-file-attributes-with-gvfs-info-regexp (concat "^[[:blank:]]*" @@ -600,6 +822,8 @@ It has been changed in GVFS 1.14.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-gvfs-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-gvfs-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-gvfs-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -625,10 +849,9 @@ First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." (unless tramp-gvfs-enabled (tramp-user-error nil "Package `tramp-gvfs' not supported")) - (let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-gvfs-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (when (featurep 'dbusbind) @@ -642,20 +865,19 @@ pass to the OPERATION." (defun tramp-gvfs-dbus-string-to-byte-array (string) "Like `dbus-string-to-byte-array' but add trailing \\0 if needed." (dbus-string-to-byte-array - (if (string-match "^(aya{sv})" tramp-gvfs-mountlocation-signature) + (if (string-match-p "^(aya{sv})" tramp-gvfs-mountlocation-signature) (concat string (string 0)) string))) (defun tramp-gvfs-dbus-byte-array-to-string (byte-array) "Like `dbus-byte-array-to-string' but remove trailing \\0 if exists. Return nil for null BYTE-ARRAY." ;; The byte array could be a variant. Take care. - (let ((byte-array - (if (and (consp byte-array) (atom (car byte-array))) - byte-array (car byte-array)))) - (and byte-array - (dbus-byte-array-to-string - (if (and (consp byte-array) (zerop (car (last byte-array)))) - (butlast byte-array) byte-array))))) + (when-let ((byte-array + (if (and (consp byte-array) (atom (car byte-array))) + byte-array (car byte-array)))) + (dbus-byte-array-to-string + (if (and (consp byte-array) (zerop (car (last byte-array)))) + (butlast byte-array) byte-array)))) (defun tramp-gvfs-stringify-dbus-message (message) "Convert a D-Bus MESSAGE into readable UTF8 strings, used for traces." @@ -680,6 +902,8 @@ The call will be traced by Tramp with trace level 6." (tramp-message vec 6 "%s" result(tramp-gvfs-stringify-dbus-message result)) result)) +(put #'tramp-dbus-function 'tramp-suppress-trace t) + (defmacro with-tramp-dbus-call-method (vec synchronous bus service path interface method &rest args) "Apply a D-Bus call on bus BUS. @@ -689,14 +913,15 @@ it is an asynchronous call, with `ignore' as callback function. The other arguments have the same meaning as with `dbus-call-method' or `dbus-call-method-asynchronously'." + (declare (indent 2) (debug t)) `(let ((func (if ,synchronous #'dbus-call-method #'dbus-call-method-asynchronously)) (args (append (list ,bus ,service ,path ,interface ,method) (if ,synchronous (list ,@args) (list 'ignore ,@args))))) - (tramp-dbus-function ,vec func args))) + ;; We use `dbus-ignore-errors', because this macro is also called + ;; when loading. + (dbus-ignore-errors (tramp-dbus-function ,vec func args)))) -(put 'with-tramp-dbus-call-method 'lisp-indent-function 2) -(put 'with-tramp-dbus-call-method 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-call-method\\>")) (defmacro with-tramp-dbus-get-all-properties @@ -704,6 +929,7 @@ or `dbus-call-method-asynchronously'." "Return all properties of INTERFACE. The call will be traced by Tramp with trace level 6." ;; Check, that interface exists at object path. Retrieve properties. + (declare (indent 1) (debug t)) `(when (member ,interface (tramp-dbus-function @@ -712,8 +938,6 @@ The call will be traced by Tramp with trace level 6." (tramp-dbus-function ,vec #'dbus-get-all-properties (list ,bus ,service ,path ,interface)))) -(put 'with-tramp-dbus-get-all-properties 'lisp-indent-function 1) -(put 'with-tramp-dbus-get-all-properties 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-dbus-get-all-properties\\>")) (defvar tramp-gvfs-dbus-event-vector nil @@ -728,6 +952,10 @@ is no information where to trace the message.") (tramp-error tramp-gvfs-dbus-event-vector 'file-error "%s" (cadr err)))) (add-hook 'dbus-event-error-functions #'tramp-gvfs-dbus-event-error) +(add-hook 'tramp-gvfs-unload-hook + (lambda () + (remove-hook 'dbus-event-error-functions + #'tramp-gvfs-dbus-event-error))) ;; File name primitives. @@ -758,11 +986,15 @@ file names." (copy-directory filename newname keep-date t) (when (eq op 'rename) (delete-directory filename 'recursive))) - (let ((t1 (tramp-tramp-file-p filename)) - (t2 (tramp-tramp-file-p newname)) - (equal-remote (tramp-equal-remote filename newname)) - (gvfs-operation (if (eq op 'copy) "gvfs-copy" "gvfs-move")) - (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) + (let* ((t1 (tramp-tramp-file-p filename)) + (t2 (tramp-tramp-file-p newname)) + (equal-remote (tramp-equal-remote filename newname)) + (gvfs-operation + (cond + ((eq op 'copy) "gvfs-copy") + (equal-remote "gvfs-rename") + (t "gvfs-move"))) + (msg-operation (if (eq op 'copy) "Copying" "Renaming"))) (with-parsed-tramp-file-name (if t1 filename newname) nil (unless (file-exists-p filename) @@ -772,7 +1004,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and equal-remote @@ -833,8 +1065,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -950,10 +1182,11 @@ file names." (with-current-buffer (tramp-get-connection-buffer v) (goto-char (point-min)) (while (looking-at - (concat "^\\(.+\\)[[:blank:]]" - "\\([[:digit:]]+\\)[[:blank:]]" - "(\\(.+?\\))" - tramp-gvfs-file-attributes-with-gvfs-ls-regexp)) + (eval-when-compile + (concat "^\\(.+\\)[[:blank:]]" + "\\([[:digit:]]+\\)[[:blank:]]" + "(\\(.+?\\))" + tramp-gvfs-file-attributes-with-gvfs-ls-regexp))) (let ((item (list (cons "type" (match-string 3)) (cons "standard::size" (match-string 2)) (cons "name" (match-string 1))))) @@ -1054,8 +1287,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::uid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::user" attributes)) (cdr (assoc "unix::uid" attributes)) tramp-unknown-id-string))) @@ -1063,8 +1295,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (if (eq id-format 'integer) (string-to-number (or (cdr (assoc "unix::gid" attributes)) - (eval-when-compile - (format "%s" tramp-unknown-id-integer)))) + (eval-when-compile (format "%s" tramp-unknown-id-integer)))) (or (cdr (assoc "owner::group" attributes)) (cdr (assoc "unix::gid" attributes)) tramp-unknown-id-string))) @@ -1244,11 +1475,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; File names are returned as URL paths. We must convert them. (when (string-match ddu file) (setq file (replace-match dd nil nil file))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" file) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" file) (setq file (url-unhex-string file))) (when (string-match ddu (or file1 "")) (setq file1 (replace-match dd nil nil file1))) - (while (string-match-p "%\\([0-9A-F]\\{2\\}\\)" (or file1 "")) + (while (string-match-p "%\\([[:xdigit:]]\\{2\\}\\)" (or file1 "")) (setq file1 (url-unhex-string file1))) ;; Remove watch when file or directory to be watched is deleted. (when (and (member action '(moved deleted)) @@ -1281,7 +1512,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." ;; If the user is different from what we guess to be ;; the user, we don't know. Let's check, whether ;; access is restricted explicitly. - (and (/= (tramp-gvfs-get-remote-uid v 'integer) + (and (/= (tramp-get-remote-uid v 'integer) (tramp-compat-file-attribute-user-id (file-attributes filename 'integer))) (not @@ -1301,10 +1532,11 @@ If FILE-SYSTEM is non-nil, return file system attributes." (size (cdr (assoc "filesystem::size" attr))) (used (cdr (assoc "filesystem::used" attr))) (free (cdr (assoc "filesystem::free" attr)))) - (when (and (stringp size) (stringp used) (stringp free)) - (list (string-to-number size) - (- (string-to-number size) (string-to-number used)) - (string-to-number free)))))) + (when (or size used free) + (list (string-to-number (or size "0")) + (string-to-number (or free "0")) + (- (string-to-number (or size "0")) + (string-to-number (or used "0")))))))) (defun tramp-gvfs-handle-make-directory (dir &optional parents) "Like `make-directory' for Tramp files." @@ -1330,8 +1562,8 @@ If FILE-SYSTEM is non-nil, return file system attributes." "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -1341,78 +1573,110 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-run-real-handler #'rename-file (list filename newname ok-if-already-exists)))) -(defun tramp-gvfs-handle-set-file-modes (filename mode) +(defun tramp-gvfs-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::mode" (number-to-string mode)))) + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint32" + (tramp-gvfs-url-file-name filename) "unix::mode" (number-to-string mode)))) -(defun tramp-gvfs-handle-set-file-times (filename &optional time) +(defun tramp-gvfs-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) - (let ((time - (if (or (null time) + (tramp-gvfs-send-command + v "gvfs-set-attribute" (if (eq flag 'nofollow) "-nt" "-t") "uint64" + (tramp-gvfs-url-file-name filename) "time::modified" + (format-time-string + "%s" (if (or (null time) (tramp-compat-time-equal-p time tramp-time-doesnt-exist) (tramp-compat-time-equal-p time tramp-time-dont-know)) (current-time) - time))) - (tramp-gvfs-send-command - v "gvfs-set-attribute" "-t" "uint64" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "time::modified" (format-time-string "%s" time))))) + time))))) + +(defun tramp-gvfs-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (if (equal id-format 'string) + (tramp-file-name-user vec) + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-user-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format))))) + +(defun tramp-gvfs-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (when-let + ((localname (tramp-get-connection-property vec "default-location" nil))) + (tramp-compat-file-attribute-group-id + (file-attributes + (tramp-make-tramp-file-name vec localname) id-format)))) -(defun tramp-gvfs-set-file-uid-gid (filename &optional uid gid) +(defun tramp-gvfs-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) (when (natnump uid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) - "unix::uid" (number-to-string uid))) + (tramp-gvfs-url-file-name filename) "unix::uid" (number-to-string uid))) (when (natnump gid) (tramp-gvfs-send-command v "gvfs-set-attribute" "-t" "uint32" - (tramp-gvfs-url-file-name (tramp-make-tramp-file-name v)) + (tramp-gvfs-url-file-name filename) "unix::gid" (number-to-string gid))))) ;; File name conversions. +(defun tramp-gvfs-activation-uri (filename) + "Return activation URI to be used in gio commands." + (if (tramp-tramp-file-p filename) + (with-parsed-tramp-file-name filename nil + ;; Ensure that media devices are cached. + (when (string-equal method "media") + (tramp-get-media-device v)) + (with-tramp-connection-property v "activation-uri" + (setq localname "/") + (when (string-equal "gdrive" method) + (setq method "google-drive")) + (when (string-equal "nextcloud" method) + (setq method "davs" + localname + (concat (tramp-gvfs-get-remote-prefix v) localname))) + (when (string-equal "media" method) + (when-let + ((media (tramp-get-connection-property v "media-device" nil))) + (setq method (tramp-media-device-method media) + host (tramp-media-device-host media) + port (tramp-media-device-port media)))) + (when (and user domain) + (setq user (concat domain ";" user))) + (url-recreate-url + (url-parse-make-urlobj + method (and user (url-hexify-string user)) + nil (and host (url-hexify-string host)) + (if (stringp port) (string-to-number port) port) + localname nil nil t)))) + ;; Local URI. + (url-recreate-url + (url-parse-make-urlobj "file" nil nil nil nil nil nil nil t)))) + (defun tramp-gvfs-url-file-name (filename) "Return FILENAME in URL syntax." - ;; "/" must NOT be hexified. (setq filename (tramp-compat-file-name-unquote filename)) - (let ((url-unreserved-chars (cons ?/ url-unreserved-chars)) - result) - (setq - result - (url-recreate-url - (if (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (when (string-equal "gdrive" method) - (setq method "google-drive")) - (when (string-equal "nextcloud" method) - (setq method "davs" - localname - (concat (tramp-gvfs-get-remote-prefix v) localname))) - (when (and user domain) - (setq user (concat domain ";" user))) - (url-parse-make-urlobj - method (and user (url-hexify-string user)) - nil (and host (url-hexify-string host)) - (if (stringp port) (string-to-number port) port) - (and localname (url-hexify-string localname)) nil nil t)) - (url-parse-make-urlobj - "file" nil nil nil nil - (url-hexify-string (file-truename filename)) nil nil t)))) + (let* (;; "/" must NOT be hexified. + (url-unreserved-chars (cons ?/ url-unreserved-chars)) + (result + (concat (substring (tramp-gvfs-activation-uri filename) 0 -1) + (url-hexify-string (tramp-file-local-name filename))))) (when (tramp-tramp-file-p filename) - (with-parsed-tramp-file-name filename nil - (tramp-message v 10 "remote file `%s' is URL `%s'" filename result))) + (tramp-message + (tramp-dissect-file-name filename) 10 + "remote file `%s' is URL `%s'" filename result)) result)) (defun tramp-gvfs-object-path (filename) @@ -1424,6 +1688,14 @@ If FILE-SYSTEM is non-nil, return file system attributes." (dbus-unescape-from-identifier (replace-regexp-in-string "^.*/\\([^/]+\\)$" "\\1" object-path))) +(defun tramp-gvfs-url-host (url) + "Return the host name part of URL, a string. +We cannot use `url-host', because `url-generic-parse-url' returns +a downcased host name only." + (and (stringp url) + (string-match "^[[:alnum:]]+://\\([^/:]+\\)" url) + (match-string 1 url))) + ;; D-Bus GVFS functions. @@ -1490,8 +1762,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (list t ;; handled. nil ;; no abort of D-Bus. - (with-tramp-connection-property - (tramp-get-connection-process v) message + (with-tramp-connection-property (tramp-get-process v) message ;; In theory, there can be several choices. ;; Until now, there is only the question whether ;; to accept an unknown host signature or certificate. @@ -1564,11 +1835,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices nil) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (member method tramp-gvfs-methods) (with-parsed-tramp-file-name (tramp-make-tramp-file-name method user domain host port "") nil @@ -1654,11 +1936,22 @@ If FILE-SYSTEM is non-nil, return file system attributes." (when (string-equal "google-drive" method) (setq method "gdrive")) (when (and (string-equal "http" method) (stringp uri)) - (setq uri (url-generic-parse-url uri) + (setq host (tramp-gvfs-url-host uri) + uri (url-generic-parse-url uri) method (url-type uri) user (url-user uri) - host (url-host uri) port (url-portspec uri))) + (when (member method tramp-media-methods) + ;; Ensure that media devices are cached. + (tramp-get-media-devices vec) + (let ((v (tramp-get-connection-property + (make-tramp-media-device + :method method :host host :port port) + "vector" nil))) + (when v + (setq method (tramp-file-name-method v) + host (tramp-file-name-host v) + port (tramp-file-name-port v))))) (when (and (string-equal method (tramp-file-name-method vec)) (string-equal user (tramp-file-name-user vec)) @@ -1683,8 +1976,7 @@ If FILE-SYSTEM is non-nil, return file system attributes." (tramp-gvfs-url-file-name (tramp-make-tramp-file-name vec)))) (while (tramp-gvfs-connection-mounted-p vec) (read-event nil nil 0.1)) - (tramp-flush-connection-properties vec) - (tramp-flush-connection-properties (tramp-get-connection-process vec))) + (tramp-cleanup-connection vec 'keep-debug 'keep-password)) (defun tramp-gvfs-mount-spec-entry (key value) "Construct a mount-spec entry to be used in a mount_spec. @@ -1696,11 +1988,16 @@ It was \"a(say)\", but has changed to \"a{sv})\"." (defun tramp-gvfs-mount-spec (vec) "Return a mount-spec for \"org.gtk.vfs.MountTracker.mountLocation\"." - (let* ((method (tramp-file-name-method vec)) + (let* ((media (tramp-get-media-device vec)) + (method (if media + (tramp-media-device-method media) + (tramp-file-name-method vec))) (user (tramp-file-name-user vec)) (domain (tramp-file-name-domain vec)) - (host (tramp-file-name-host vec)) - (port (tramp-file-name-port vec)) + (host (if media + (tramp-media-device-host media) (tramp-file-name-host vec))) + (port (if media + (tramp-media-device-port media) (tramp-file-name-port vec))) (localname (tramp-file-name-unquote-localname vec)) (share (when (string-match "^/?\\([^/]+\\)" localname) (match-string 1 localname))) @@ -1751,42 +2048,41 @@ It was \"a(say)\", but has changed to \"a{sv})\"." ;; Return. `(:struct ,(tramp-gvfs-dbus-string-to-byte-array mount-pref) ,mount-spec))) +(defun tramp-gvfs-handler-volumeadded-volumeremoved (_dbus-name _id volume) + "Signal handler for the \"org.gtk.Private.RemoteVolumeMonitor.VolumeAdded\" \ +and \"org.gtk.Private.RemoteVolumeMonitor.VolumeRemoved\" signals." + (ignore-errors + (let* ((signal-name (dbus-event-member-name last-input-event)) + (uri (url-generic-parse-url (nth 5 volume))) + (method (url-type uri)) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri))))) + (when (member method tramp-media-methods) + (tramp-message + vec 6 "%s %s" signal-name (tramp-gvfs-stringify-dbus-message volume)) + (tramp-flush-connection-properties vec) + (tramp-flush-connection-properties media) + (tramp-get-media-devices nil))))) + +(when tramp-gvfs-enabled + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeAdded" + #'tramp-gvfs-handler-volumeadded-volumeremoved) + (dbus-register-signal + :session nil tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "VolumeRemoved" + #'tramp-gvfs-handler-volumeadded-volumeremoved)) + ;; Connection functions. -(defun tramp-gvfs-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((user (tramp-file-name-user vec)) - (localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - ((and (equal id-format 'string) user)) - (localname - (tramp-compat-file-attribute-user-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defun tramp-gvfs-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((localname - (tramp-get-connection-property vec "default-location" nil))) - (cond - (localname - (tramp-compat-file-attribute-group-id - (file-attributes - (tramp-make-tramp-file-name vec localname) id-format))) - ((equal id-format 'integer) tramp-unknown-id-integer) - ((equal id-format 'string) tramp-unknown-id-string))))) - -(defvar tramp-gvfs-get-remote-uid-gid-in-progress nil - "Indication, that remote uid and gid determination is in progress.") - (defun tramp-gvfs-get-remote-prefix (vec) "The prefix of the remote connection VEC. This is relevant for GNOME Online Accounts." @@ -1794,7 +2090,7 @@ This is relevant for GNOME Online Accounts." ;; Ensure that GNOME Online Accounts are cached. (when (member (tramp-file-name-method vec) tramp-goa-methods) (tramp-get-goa-accounts vec)) - (tramp-get-connection-property (tramp-make-goa-name vec) "prefix" "/"))) + (tramp-get-connection-property (tramp-get-goa-account vec) "prefix" "/"))) (defun tramp-gvfs-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -1843,7 +2139,7 @@ connection if a previous connection has died for some reason." ;; Ensure that GNOME Online Accounts are cached. (tramp-get-goa-accounts vec) (when (tramp-get-connection-property - (tramp-make-goa-name vec) "FilesDisabled" t) + (tramp-get-goa-account vec) "FilesDisabled" t) (tramp-user-error vec "There is no Online Account `%s'" (tramp-make-tramp-file-name vec 'noloc)))) @@ -1926,16 +2222,7 @@ connection if a previous connection has died for some reason." ;; Mark it as connected. (tramp-set-connection-property - (tramp-get-connection-process vec) "connected" t)))) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (unless tramp-gvfs-get-remote-uid-gid-in-progress - (let ((tramp-gvfs-get-remote-uid-gid-in-progress t)) - (tramp-gvfs-get-remote-uid vec 'integer) - (tramp-gvfs-get-remote-gid vec 'integer) - (tramp-gvfs-get-remote-uid vec 'string) - (tramp-gvfs-get-remote-gid vec 'string)))) + (tramp-get-connection-process vec) "connected" t))))) (defun tramp-gvfs-gio-tool-p (vec) "Check, whether the gio tool is available." @@ -1968,12 +2255,12 @@ is applied, and it returns t if the return code is zero." (and (tramp-flush-file-properties vec "/") nil))))) -;; D-Bus GNOME Online Accounts functions. +;; GNOME Online Accounts functions. -(defun tramp-make-goa-name (vec) - "Transform VEC into a `tramp-goa-name' structure." +(defun tramp-get-goa-account (vec) + "Transform VEC into a `tramp-goa-account' structure." (when (tramp-file-name-p vec) - (make-tramp-goa-name + (make-tramp-goa-account :method (tramp-file-name-method vec) :user (tramp-file-name-user vec) :host (tramp-file-name-host vec) @@ -1981,12 +2268,12 @@ is applied, and it returns t if the return code is zero." (defun tramp-get-goa-accounts (vec) "Retrieve GNOME Online Accounts, and cache them. -The hash key is a `tramp-goa-name' structure. The value is an +The hash key is a `tramp-goa-account' structure. The value is an alist of the properties of `tramp-goa-interface-account' and -`tramp-goa-interface-files' of the corresponding GNOME online -account. Additionally, a property \"prefix\" is added. +`tramp-goa-interface-files' of the corresponding GNOME Online +Account. Additionally, a property \"prefix\" is added. VEC is used only for traces." - (with-tramp-connection-property (tramp-make-goa-name vec) "goa-accounts" + (with-tramp-connection-property nil "goa-accounts" (dolist (object-path (mapcar @@ -2012,15 +2299,15 @@ VEC is used only for traces." (cdr (assoc "ProviderType" account-properties)) '("google" "owncloud")) (string-match tramp-goa-identity-regexp identity)) - (setq key (make-tramp-goa-name + (setq key (make-tramp-goa-account :method (cdr (assoc "ProviderType" account-properties)) :user (match-string 1 identity) :host (match-string 2 identity) :port (match-string 3 identity))) - (when (string-equal (tramp-goa-name-method key) "google") - (setf (tramp-goa-name-method key) "gdrive")) - (when (string-equal (tramp-goa-name-method key) "owncloud") - (setf (tramp-goa-name-method key) "nextcloud")) + (when (string-equal (tramp-goa-account-method key) "google") + (setf (tramp-goa-account-method key) "gdrive")) + (when (string-equal (tramp-goa-account-method key) "owncloud") + (setf (tramp-goa-account-method key) "nextcloud")) ;; Cache all properties. (dolist (prop (nconc account-properties files-properties)) (tramp-set-connection-property key (car prop) (cdr prop))) @@ -2036,6 +2323,80 @@ VEC is used only for traces." ;; Mark, that goa accounts have been cached. "cached")) +(defun tramp-parse-goa-accounts (service) + "Return a list of (user host) tuples allowed to access. +It checks for registered GNOME Online Accounts." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-goa-account-p key) + (string-equal service (tramp-goa-account-method key)) + (list (tramp-goa-account-user key) + (tramp-goa-account-host key)))) + (hash-table-keys tramp-cache-data))) + + +;; Media devices functions. + +(defun tramp-get-media-device (vec) + "Transform VEC into a `tramp-media-device' structure. +Check, that respective cache values do exist." + (if-let ((media (tramp-get-connection-property vec "media-device" nil)) + (prop (tramp-get-connection-property media "vector" nil))) + media + (tramp-get-media-devices vec) + (tramp-get-connection-property vec "media-device" nil))) + +(defun tramp-get-media-devices (vec) + "Retrieve media devices, and cache them. +The hash key is a `tramp-media-device' structure. +VEC is used only for traces." + (let (devices) + (dolist (method tramp-media-methods) + (dolist (volume (cadr (with-tramp-dbus-call-method vec t + :session (tramp-gvfs-service-volumemonitor method) + tramp-gvfs-path-remotevolumemonitor + tramp-gvfs-interface-remotevolumemonitor "List"))) + (let* ((uri (url-generic-parse-url (nth 5 volume))) + (vec (make-tramp-file-name + :method "media" + ;; A host name cannot contain spaces. + :host (replace-regexp-in-string " " "_" (nth 1 volume)))) + (media (make-tramp-media-device + :method method + :host (tramp-gvfs-url-host (nth 5 volume)) + :port (and (url-portspec uri) + (number-to-string (url-portspec uri)))))) + (push (tramp-file-name-host vec) devices) + (tramp-set-connection-property vec "activation-uri" (nth 5 volume)) + (tramp-set-connection-property vec "media-device" media) + (tramp-set-connection-property media "vector" vec)))) + + ;; Adapt default host name, supporting /media:: when possible. + (setq tramp-default-host-alist + (append + `(("media" nil ,(if (= (length devices) 1) (car devices) ""))) + (delete + (assoc "media" tramp-default-host-alist) + tramp-default-host-alist))))) + +(defun tramp-parse-media-names (service) + "Return a list of (user host) tuples allowed to access. +It checks for mounted media devices." + ;; SERVICE might be encoded as a DNS-SD service. + (and (string-match tramp-dns-sd-service-regexp service) + (setq service (match-string 1 service))) + (mapcar + (lambda (key) + (and (tramp-media-device-p key) + (string-equal service (tramp-media-device-method key)) + (tramp-get-connection-property key "vector" nil) + (list nil (tramp-file-name-host + (tramp-get-connection-property key "vector" nil))))) + (hash-table-keys tramp-cache-data))) + ;; D-Bus zeroconf functions. @@ -2080,39 +2441,62 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." (list user host))) result)))) -;; Add completion functions for AFP, DAV, DAVS, SFTP and SMB methods. (when tramp-gvfs-enabled - ;; Suppress D-Bus error messages. - (let (tramp-gvfs-dbus-event-vector) + ;; Suppress D-Bus error messages and Tramp traces. + (let ((tramp-verbose 0) + tramp-gvfs-dbus-event-vector fun) + ;; Add completion functions for services announced by DNS-SD. + ;; See <http://www.dns-sd.org/ServiceTypes.html> for valid service types. (zeroconf-init tramp-gvfs-zeroconf-domain) - (if (zeroconf-list-service-types) - (progn - (tramp-set-completion-function - "afp" '((tramp-zeroconf-parse-device-names "_afpovertcp._tcp"))) - (tramp-set-completion-function - "dav" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "davs" '((tramp-zeroconf-parse-device-names "_webdav._tcp"))) - (tramp-set-completion-function - "sftp" '((tramp-zeroconf-parse-device-names "_ssh._tcp") - (tramp-zeroconf-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-zeroconf-parse-device-names "_smb._tcp"))))) - - (when (executable-find "avahi-browse") + (when (setq fun (or (and (zeroconf-list-service-types) + #'tramp-zeroconf-parse-device-names) + (and (executable-find "avahi-browse") + #'tramp-gvfs-parse-device-names))) + (when (member "afp" tramp-gvfs-methods) + (tramp-set-completion-function + "afp" `((,fun "_afpovertcp._tcp")))) + (when (member "dav" tramp-gvfs-methods) + (tramp-set-completion-function + "dav" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "davs" tramp-gvfs-methods) + (tramp-set-completion-function + "davs" `((,fun "_webdav._tcp") + (,fun "_webdavs._tcp")))) + (when (member "ftp" tramp-gvfs-methods) (tramp-set-completion-function - "afp" '((tramp-gvfs-parse-device-names "_afpovertcp._tcp"))) + "ftp" `((,fun "_ftp._tcp")))) + (when (member "http" tramp-gvfs-methods) (tramp-set-completion-function - "dav" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "http" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "https" tramp-gvfs-methods) (tramp-set-completion-function - "davs" '((tramp-gvfs-parse-device-names "_webdav._tcp"))) + "https" `((,fun "_http._tcp") + (,fun "_https._tcp")))) + (when (member "sftp" tramp-gvfs-methods) (tramp-set-completion-function - "sftp" '((tramp-gvfs-parse-device-names "_ssh._tcp") - (tramp-gvfs-parse-device-names "_workstation._tcp"))) - (when (member "smb" tramp-gvfs-methods) - (tramp-set-completion-function - "smb" '((tramp-gvfs-parse-device-names "_smb._tcp")))))))) + "sftp" `((,fun "_sftp-ssh._tcp") + (,fun "_ssh._tcp") + (,fun "_workstation._tcp")))) + (when (member "smb" tramp-gvfs-methods) + (tramp-set-completion-function + "smb" `((,fun "_smb._tcp"))))) + + ;; Add completion functions for GNOME Online Accounts. + (tramp-get-goa-accounts nil) + (dolist (method tramp-goa-methods) + (when (member method tramp-gvfs-methods) + (tramp-set-completion-function + method `((tramp-parse-goa-accounts ,(format "_%s._tcp" method)))))) + + ;; Add completion functions for media devices. + (tramp-get-media-devices nil) + (tramp-set-completion-function + "media" + (mapcar + (lambda (method) `(tramp-parse-media-names ,(format "_%s._tcp" method))) + tramp-media-methods)))) (add-hook 'tramp-unload-hook (lambda () @@ -2125,7 +2509,7 @@ This uses \"avahi-browse\" in case D-Bus is not enabled in Avahi." ;; * (Customizable) unmount when exiting Emacs. See tramp-archive.el. ;; ;; * Host name completion for existing mount points (afp-server, -;; smb-server, google-drive, nextcloud) or via smb-network or network. +;; smb-server) or via smb-network or network. ;; ;; * Check, how two shares of the same SMB server can be mounted in ;; parallel. diff --git a/lisp/net/tramp-rclone.el b/lisp/net/tramp-rclone.el index 9f539850139..3701bfc22c9 100644 --- a/lisp/net/tramp-rclone.el +++ b/lisp/net/tramp-rclone.el @@ -135,6 +135,8 @@ (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -157,10 +159,9 @@ Operations not mentioned here will be handled by the default Emacs primitives.") "Invoke the rclone handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-rclone-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -220,7 +221,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and t1 (not (tramp-rclone-file-name-p filename))) @@ -271,8 +272,8 @@ file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -429,8 +430,8 @@ file names." (defun tramp-rclone-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -458,7 +459,7 @@ file names." ;; to cache a nil result. (or (tramp-get-connection-property (tramp-get-connection-process vec) "mounted" nil) - (let* ((default-directory temporary-file-directory) + (let* ((default-directory (tramp-compat-temporary-file-directory)) (mount (shell-command-to-string "mount -t fuse.rclone"))) (tramp-message vec 6 "%s" "mount -t fuse.rclone") (tramp-message vec 6 "\n%s" mount) @@ -478,7 +479,19 @@ file names." (with-tramp-connection-property (tramp-get-connection-process vec) "rclone-pid" (catch 'pid - (dolist (pid (list-system-processes)) ;; "pidof rclone" ? + (dolist + (pid + ;; Until Emacs 25, `process-attributes' could + ;; crash Emacs for some processes. So we use + ;; "pidof", which might not work everywhere. + (if (<= emacs-major-version 25) + (let ((default-directory + (tramp-compat-temporary-file-directory))) + (mapcar + #'string-to-number + (split-string + (shell-command-to-string "pidof rclone")))) + (list-system-processes))) (and (string-match-p (regexp-quote (format "rclone mount %s:" (tramp-file-name-host vec))) @@ -564,7 +577,7 @@ connection if a previous connection has died for some reason." ,(tramp-rclone-mount-point vec) ;; This could be nil. ,(tramp-get-method-parameter vec 'tramp-mount-args)))) - (while (not (file-exists-p (tramp-make-tramp-file-name vec 'localname))) + (while (not (file-exists-p (tramp-make-tramp-file-name vec 'noloc))) (tramp-cleanup-connection vec 'keep-debug 'keep-password)) ;; Mark it as connected. diff --git a/lisp/net/tramp-sh.el b/lisp/net/tramp-sh.el index af97328b3d3..4dc95b1bb05 100644 --- a/lisp/net/tramp-sh.el +++ b/lisp/net/tramp-sh.el @@ -90,10 +90,10 @@ the default storage location, e.g. \"$HOME/.sh_history\"." (string :tag "Redirect to a file"))) ;;;###tramp-autoload -(defconst tramp-display-escape-sequence-regexp "\e[[;0-9]+m" +(defconst tramp-display-escape-sequence-regexp "\e[[:digit:];[]+m" "Terminal control escape sequences for display attributes.") -(defconst tramp-device-escape-sequence-regexp "\e[[0-9]+n" +(defconst tramp-device-escape-sequence-regexp "\e[[:digit:][]+n" "Terminal control escape sequences for device status.") ;; ksh on OpenBSD 4.5 requires that $PS1 contains a `#' character for @@ -481,6 +481,7 @@ The string is used in `tramp-methods'.") ;; Darwin: /usr/bin:/bin:/usr/sbin:/sbin ;; IRIX64: /usr/bin ;; QNAP QTS: --- +;; Hydra: /run/current-system/sw/bin:/bin:/usr/bin ;;;###tramp-autoload (defcustom tramp-remote-path '(tramp-default-remote-path "/bin" "/usr/bin" "/sbin" "/usr/sbin" @@ -491,8 +492,8 @@ The string is used in `tramp-methods'.") For every remote host, this variable will be set buffer local, keeping the list of existing directories on that host. -You can use `~' in this list, but when searching for a shell which groks -tilde expansion, all directory names starting with `~' will be ignored. +You can use \"~\" in this list, but when searching for a shell which groks +tilde expansion, all directory names starting with \"~\" will be ignored. `Default Directories' represent the list of directories given by the command \"getconf PATH\". It is recommended to use this @@ -537,12 +538,13 @@ based on the Tramp and Emacs versions, and should not be set here." ;;;###tramp-autoload (defcustom tramp-sh-extra-args - '(("/bash\\'" . "-norc -noprofile") + '(("/bash\\'" . "-noediting -norc -noprofile") ("/zsh\\'" . "-f +Z -V")) "Alist specifying extra arguments to pass to the remote shell. Entries are (REGEXP . ARGS) where REGEXP is a regular expression matching the shell file name and ARGS is a string specifying the -arguments. +arguments. These arguments shall disable line editing, see +`tramp-open-shell'. This variable is only used when Tramp needs to start up another shell for tilde expansion. The extra arguments should typically prevent the @@ -866,8 +868,12 @@ Escape sequence %s is replaced with name of Perl binary.") "Perl program to use for decoding a file. Escape sequence %s is replaced with name of Perl binary.") +(defconst tramp-hexdump-encode "%h -v -e '16/1 \" %%02x\" \"\\n\"'" + "`hexdump' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + (defconst tramp-awk-encode - "od -v -t x1 -A n | busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" b16 = \"0123456789abcdef\" @@ -897,11 +903,25 @@ END { } printf tail }'" - "Awk program to use for encoding a file. + "`awk' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-hexdump-awk-encode + (format "%s | %s" tramp-hexdump-encode tramp-awk-encode) + "`hexdump' / `awk' pipe to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-encode "%o -v -t x1 -A n" + "`od' program to use for encoding a file. +This string is passed to `format', so percent characters need to be doubled.") + +(defconst tramp-od-awk-encode + (format "%s | %s" tramp-od-encode tramp-awk-encode) + "`od' / `awk' pipe to use for encoding a file. This string is passed to `format', so percent characters need to be doubled.") (defconst tramp-awk-decode - "busybox awk '\\ + "%a '\\ BEGIN { b64 = \"ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/\" } @@ -926,12 +946,6 @@ BEGIN { "Awk program to use for decoding a file. This string is passed to `format', so percent characters need to be doubled.") -(defconst tramp-awk-coding-test - "test -c /dev/zero && \ -od -v -t x1 -A n </dev/null && \ -busybox awk '{}' </dev/null" - "Test command for checking `tramp-awk-encode' and `tramp-awk-decode'.") - (defconst tramp-vc-registered-read-file-names "echo \"(\" while read file; do @@ -1025,6 +1039,8 @@ of command line.") (start-file-process . tramp-handle-start-file-process) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sh-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sh-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sh-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . tramp-sh-handle-vc-registered) @@ -1051,9 +1067,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1104,8 +1118,7 @@ component is used as the target of the symlink." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -1142,59 +1155,9 @@ component is used as the target of the symlink." (tramp-shell-quote-argument localname))))) ;; Do it yourself. - (t (let ((steps (split-string localname "/" 'omit)) - (thisstep nil) - (numchase 0) - ;; Don't make the following value larger than - ;; necessary. People expect an error message in a - ;; timely fashion when something is wrong; - ;; otherwise they might think that Emacs is hung. - ;; Of course, correctness has to come first. - (numchase-limit 20) - symlink-target) - (while (and steps (< numchase numchase-limit)) - (setq thisstep (pop steps)) - (tramp-message - v 5 "Check %s" - (string-join - (append '("") (reverse result) (list thisstep)) "/")) - (setq symlink-target - (tramp-compat-file-attribute-type - (file-attributes - (tramp-make-tramp-file-name - v - (string-join - (append - '("") (reverse result) (list thisstep)) "/") - 'nohop)))) - (cond ((string= "." thisstep) - (tramp-message v 5 "Ignoring step `.'")) - ((string= ".." thisstep) - (tramp-message v 5 "Processing step `..'") - (pop result)) - ((stringp symlink-target) - ;; It's a symlink, follow it. - (tramp-message - v 5 "Follow symlink to %s" symlink-target) - (setq numchase (1+ numchase)) - (when (file-name-absolute-p symlink-target) - (setq result nil)) - (setq steps - (append - (split-string symlink-target "/" 'omit) - steps))) - (t - ;; It's a file. - (setq result (cons thisstep result))))) - (when (>= numchase numchase-limit) - (tramp-error - v 'file-error - "Maximum number (%d) of symlinks exceeded" numchase-limit)) - (setq result (reverse result)) - ;; Combine list to form string. - (setq result - (if result (string-join (cons "" result) "/") "/")) - (when (string-empty-p result) (setq result "/"))))) + (t (setq + result + (tramp-file-local-name (tramp-handle-file-truename filename))))) ;; Detect cycle. (when (and (file-symlink-p filename) @@ -1263,8 +1226,8 @@ component is used as the target of the symlink." (defun tramp-do-file-attributes-with-ls (vec localname &optional id-format) "Implement `file-attributes' for Tramp files using the ls(1) command." (let (symlinkp dirp - res-inode res-filemodes res-numlinks - res-uid res-gid res-size res-symlink-target) + res-inode res-filemodes res-numlinks + res-uid res-gid res-size res-symlink-target) (tramp-message vec 5 "file attributes with ls: %s" localname) ;; We cannot send all three commands combined, it could exceed ;; NAME_MAX or PATH_MAX. Happened on macOS, for example. @@ -1366,20 +1329,12 @@ component is used as the target of the symlink." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; On Opsware, pdksh (which is the true name of ksh there) - ;; doesn't parse correctly the sequence "((". Therefore, we - ;; add a space. Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "( (%s %s || %s -h %s) && (%s -c " - "'((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "%s | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g') || echo nil)")) - (tramp-get-file-exists-command vec) - (tramp-shell-quote-argument localname) - (tramp-get-test-command vec) - (tramp-shell-quote-argument localname) + (concat + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "(%s -c '((%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' %s |" + " sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g')") (tramp-get-remote-stat vec) tramp-stat-marker tramp-stat-marker (if (eq id-format 'integer) @@ -1390,7 +1345,8 @@ component is used as the target of the symlink." (eval-when-compile (concat tramp-stat-marker "%G" tramp-stat-marker))) tramp-stat-marker tramp-stat-marker (tramp-shell-quote-argument localname) - tramp-stat-quoted-marker))) + tramp-stat-quoted-marker) + 'noerror)) (defun tramp-sh-handle-set-visited-file-modtime (&optional time-list) "Like `set-visited-file-modtime' for Tramp files." @@ -1468,17 +1424,24 @@ of." ;; only if that agrees with the buffer's record. (t (tramp-compat-time-equal-p mt tramp-time-doesnt-exist))))))))) -(defun tramp-sh-handle-set-file-modes (filename mode) +(defun tramp-sh-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - ;; FIXME: extract the proper text from chmod's stderr. - (tramp-barf-unless-okay - v - (format "chmod %o %s" mode (tramp-shell-quote-argument localname)) - "Error while changing file's mode %s" filename))) + ;; We need "chmod -h" when the flag is set. + (when (or (not (eq flag 'nofollow)) + (not (file-symlink-p filename)) + (tramp-get-remote-chmod-h v)) + (tramp-flush-file-properties v localname) + ;; FIXME: extract the proper text from chmod's stderr. + (tramp-barf-unless-okay + v + (format + "chmod %s %o %s" + (if (and (eq flag 'nofollow) (tramp-get-remote-chmod-h v)) "-h" "") + mode (tramp-shell-quote-argument localname)) + "Error while changing file's mode %s" filename)))) -(defun tramp-sh-handle-set-file-times (filename &optional time) +(defun tramp-sh-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (when (tramp-get-remote-touch v) @@ -1491,13 +1454,34 @@ of." time))) (tramp-send-command-and-check v (format - "env TZ=UTC %s %s %s" + "env TZ=UTC %s %s %s %s" (tramp-get-remote-touch v) (if (tramp-get-connection-property v "touch-t" nil) (format "-t %s" (format-time-string "%Y%m%d%H%M.%S" time t)) "") + (if (eq flag 'nofollow) "-h" "") (tramp-shell-quote-argument localname))))))) +(defun tramp-sh-handle-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-uid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-uid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-uid-with-python vec id-format))))) + +(defun tramp-sh-handle-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (ignore-errors + (cond + ((tramp-get-remote-id vec) (tramp-get-remote-gid-with-id vec id-format)) + ((tramp-get-remote-perl vec) (tramp-get-remote-gid-with-perl vec id-format)) + ((tramp-get-remote-python vec) + (tramp-get-remote-gid-with-python vec id-format))))) + (defun tramp-sh-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." ;; Modern Unices allow chown only for root. So we might need @@ -1521,7 +1505,7 @@ of." (defun tramp-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (tramp-send-command-and-check vec "selinuxenabled"))) (defun tramp-sh-handle-file-selinux-context (filename) @@ -1529,9 +1513,8 @@ of." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-remote-selinux-p v) (tramp-send-command-and-check v (format @@ -1570,7 +1553,7 @@ of." (defun tramp-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (tramp-send-command-and-check vec "getfacl /"))) (defun tramp-sh-handle-file-acl (filename) @@ -1700,8 +1683,10 @@ of." (defun tramp-sh-handle-file-ownership-preserved-p (filename &optional group) "Like `file-ownership-preserved-p' for Tramp files." (with-parsed-tramp-file-name filename nil - (with-tramp-file-property v localname "file-ownership-preserved-p" - (let ((attributes (file-attributes filename))) + (with-tramp-file-property + v localname + (format "file-ownership-preserved-p%s" (if group "-group" "")) + (let ((attributes (file-attributes filename 'integer))) ;; Return t if the file doesn't exist, since it's true that no ;; information would be lost by an (attempted) delete and create. (or (null attributes) @@ -1779,21 +1764,19 @@ of." (tramp-send-command-and-read vec (format - (eval-when-compile - (concat - ;; We must care about file names with spaces, or starting with - ;; "-"; this would confuse xargs. "ls -aQ" might be a - ;; solution, but it does not work on all remote systems. - ;; Therefore, we use \000 as file separator. - ;; `tramp-sh--quoting-style-options' do not work for file names - ;; with spaces piped to "xargs". - ;; Apostrophes in the stat output are masked as - ;; `tramp-stat-marker', in order to make a proper shell escape - ;; of them in file names. - "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " - "xargs -0 %s -c " - "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " - "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"")) + (concat + ;; We must care about file names with spaces, or starting with + ;; "-"; this would confuse xargs. "ls -aQ" might be a solution, + ;; but it does not work on all remote systems. Therefore, we use + ;; \000 as file separator. `tramp-sh--quoting-style-options' do + ;; not work for file names with spaces piped to "xargs". + ;; Apostrophes in the stat output are masked as + ;; `tramp-stat-marker', in order to make a proper shell escape of + ;; them in file names. + "cd %s && echo \"(\"; (%s %s -a | tr '\\n\\r' '\\000\\000' | " + "xargs -0 %s -c " + "'(%s%%n%s (%s%%N%s) %%h %s %s %%X %%Y %%Z %%s %s%%A%s t %%i -1)' " + "-- 2>/dev/null | sed -e 's/\"/\\\\\"/g' -e 's/%s/\"/g'); echo \")\"") (tramp-shell-quote-argument localname) (tramp-get-ls-command vec) ;; On systems which have no quoting style, file names with special @@ -1834,13 +1817,12 @@ of." (format "tramp_perl_file_name_all_completions %s" (tramp-shell-quote-argument localname))) - (format (eval-when-compile - (concat - "(cd %s 2>&1 && %s -a 2>/dev/null" - " | while IFS= read f; do" - " if %s -d \"$f\" 2>/dev/null;" - " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" - " && \\echo ok) || \\echo fail")) + (format (concat + "(cd %s 2>&1 && %s -a 2>/dev/null" + " | while IFS= read f; do" + " if %s -d \"$f\" 2>/dev/null;" + " then \\echo \"$f/\"; else \\echo \"$f\"; fi; done" + " && \\echo ok) || \\echo fail") (tramp-shell-quote-argument localname) (tramp-get-ls-command v) (tramp-get-test-command v)))) @@ -1948,7 +1930,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" ;; scp or rsync DTRT. (progn (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (setq dirname (directory-file-name (expand-file-name dirname)) newname (directory-file-name (expand-file-name newname))) @@ -1961,7 +1943,7 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" (unless (file-directory-p (file-name-directory newname)) (make-directory (file-name-directory newname) parents)) (tramp-do-copy-or-rename-file-out-of-band - 'copy dirname newname keep-date)) + 'copy dirname newname 'ok-if-already-exists keep-date)) ;; We must do it file-wise. (tramp-run-real-handler @@ -1978,8 +1960,8 @@ tramp-sh-handle-file-name-all-completions: internal error accessing `%s': `%s'" "Like `rename-file' for Tramp files." ;; Check if both files are local -- invoke normal rename-file. ;; Otherwise, use Tramp from local system. - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -2030,7 +2012,7 @@ file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -2057,7 +2039,7 @@ file names." (tramp-method-out-of-band-p v1 length) (tramp-method-out-of-band-p v2 length)) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; No shortcut was possible. So we copy the file ;; first. If the operation was `rename', we go back @@ -2070,7 +2052,7 @@ file names." ;; source and target file. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))))) + op filename newname ok-if-already-exists keep-date)))))) ;; One file is a Tramp file, the other one is local. ((or t1 t2) @@ -2085,11 +2067,11 @@ file names." ;; corresponding copy-program can be invoked. ((tramp-method-out-of-band-p v length) (tramp-do-copy-or-rename-file-out-of-band - op filename newname keep-date)) + op filename newname ok-if-already-exists keep-date)) ;; Use the inline method via a Tramp buffer. (t (tramp-do-copy-or-rename-file-via-buffer - op filename newname keep-date)))) + op filename newname ok-if-already-exists keep-date)))) (t ;; One of them must be a Tramp file. @@ -2111,7 +2093,8 @@ file names." (with-parsed-tramp-file-name newname v2 (tramp-flush-file-properties v2 v2-localname)))))))) -(defun tramp-do-copy-or-rename-file-via-buffer (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-via-buffer + (op filename newname ok-if-already-exists keep-date) "Use an Emacs buffer to copy or rename a file. First arg OP is either `copy' or `rename' and indicates the operation. FILENAME is the source file, NEWNAME the target file. @@ -2139,10 +2122,11 @@ KEEP-DATE is non-nil if NEWNAME should have the same timestamp as FILENAME." (insert-file-contents-literally filename))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (set-file-modes newname (tramp-default-file-modes filename)) ;; If the operation was `rename', delete the original file. @@ -2171,8 +2155,8 @@ the uid and gid from FILENAME." v 'file-error "Unknown operation `%s', must be `copy' or `rename'" op)))) - (localname1 (tramp-compat-file-local-name filename)) - (localname2 (tramp-compat-file-local-name newname)) + (localname1 (tramp-file-local-name filename)) + (localname2 (tramp-file-local-name newname)) (prefix (file-remote-p (if t1 filename newname))) cmd-result) (when (and (eq op 'copy) (file-directory-p filename)) @@ -2296,10 +2280,12 @@ the uid and gid from FILENAME." ;; Set the time and mode. Mask possible errors. (ignore-errors (when keep-date - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes)))))) -(defun tramp-do-copy-or-rename-file-out-of-band (op filename newname keep-date) +(defun tramp-do-copy-or-rename-file-out-of-band + (op filename newname ok-if-already-exists keep-date) "Invoke `scp' program to copy. The method used must be an out-of-band method." (let* ((t1 (tramp-tramp-file-p filename)) @@ -2322,9 +2308,9 @@ The method used must be an out-of-band method." (unwind-protect (progn (tramp-do-copy-or-rename-file-out-of-band - op filename tmpfile keep-date) + op filename tmpfile ok-if-already-exists keep-date) (tramp-do-copy-or-rename-file-out-of-band - 'rename tmpfile newname keep-date)) + 'rename tmpfile newname ok-if-already-exists keep-date)) ;; Save exit. (ignore-errors (if dir-flag @@ -2498,10 +2484,11 @@ The method used must be an out-of-band method." ;; Handle KEEP-DATE argument. (when (and keep-date (not copy-keep-date)) - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless (and keep-date copy-keep-date) @@ -2714,7 +2701,7 @@ The method used must be an out-of-band method." (when (file-symlink-p filename) (goto-char (search-backward "->" beg 'noerror))) (search-backward - (if (tramp-compat-directory-name-p filename) + (if (directory-name-p filename) "." (file-name-nondirectory filename)) beg 'noerror) @@ -2724,12 +2711,11 @@ The method used must be an out-of-band method." (goto-char (point-min)) ;; First find the line to put it on. (when (re-search-forward "^\\([[:space:]]*total\\)" nil t) - (let ((available (get-free-disk-space "."))) - (when available - ;; Replace "total" with "total used", to avoid confusion. - (replace-match "\\1 used in directory") - (end-of-line) - (insert " available " available)))) + (when-let ((available (get-free-disk-space "."))) + ;; Replace "total" with "total used", to avoid confusion. + (replace-match "\\1 used in directory") + (end-of-line) + (insert " available " available))) (goto-char (point-max))))))) @@ -2796,8 +2782,11 @@ the result will be a local, non-Tramp, file name." ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once ;; connection has been setup. +;; The complete STDERR buffer is available only when the process has +;; terminated. (defun tramp-sh-handle-make-process (&rest args) - "Like `make-process' for Tramp files." + "Like `make-process' for Tramp files. +STDERR can also be a file name." (when args (with-parsed-tramp-file-name (expand-file-name default-directory) nil (let ((name (plist-get args :name)) @@ -2829,14 +2818,23 @@ the result will be a local, non-Tramp, file name." (signal 'wrong-type-argument (list #'functionp sentinel))) (unless (or (null stderr) (bufferp stderr) (stringp stderr)) (signal 'wrong-type-argument (list #'stringp stderr))) + (when (and (stringp stderr) (tramp-tramp-file-p stderr) + (not (tramp-equal-remote default-directory stderr))) + (signal 'file-error (list "Wrong stderr" stderr))) (let* ((buffer (if buffer (get-buffer-create buffer) ;; BUFFER can be nil. We use a temporary buffer. (generate-new-buffer tramp-temp-buffer-name))) - (stderr (and stderr (get-buffer-create stderr))) - (tmpstderr (and stderr (tramp-make-tramp-temp-file v))) + ;; STDERR can also be a file name. + (tmpstderr + (and stderr + (if (and (stringp stderr) (tramp-tramp-file-p stderr)) + (tramp-unquote-file-local-name stderr) + (tramp-make-tramp-temp-file v)))) + (remote-tmpstderr + (and tmpstderr (tramp-make-tramp-file-name v tmpstderr))) (program (car command)) (args (cdr command)) ;; When PROGRAM matches "*sh", and the first arg is @@ -2877,6 +2875,11 @@ the result will be a local, non-Tramp, file name." (setq uenv (cons elt uenv))))))) (command (when (stringp program) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (format "cd %s && %s exec %s %s env %s %s" (tramp-shell-quote-argument localname) (if uenv @@ -2965,21 +2968,35 @@ the result will be a local, non-Tramp, file name." (ignore-errors (set-process-query-on-exit-flag p (null noquery)) (set-marker (process-mark p) (point))) + ;; We must flush them here already; otherwise + ;; `rename-file', `delete-file' or + ;; `insert-file-contents' will fail. + (tramp-flush-connection-property v "process-name") + (tramp-flush-connection-property v "process-buffer") + ;; Copy tmpstderr file. + (when (and (stringp stderr) + (not (tramp-tramp-file-p stderr))) + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (rename-file remote-tmpstderr stderr)))) ;; Provide error buffer. This shows only ;; initial error messages; messages arriving - ;; later on shall be inserted by `auto-revert'. - ;; The temporary file will still be existing. - ;; TODO: Write a sentinel, which deletes the - ;; temporary file. - (when tmpstderr - ;; We must flush them here already; otherwise - ;; `insert-file-contents' will fail. - (tramp-flush-connection-property v "process-name") - (tramp-flush-connection-property v "process-buffer") + ;; later on will be inserted when the process is + ;; deleted. The temporary file will exist until + ;; the process is deleted. + (when (bufferp stderr) (with-current-buffer stderr - (insert-file-contents - (tramp-make-tramp-file-name v tmpstderr) 'visit) - (auto-revert-mode))) + (insert-file-contents-literally remote-tmpstderr)) + ;; Delete tmpstderr file. + (add-function + :after (process-sentinel p) + (lambda (_proc _msg) + (when (file-exists-p remote-tmpstderr) + (with-current-buffer stderr + (insert-file-contents-literally + remote-tmpstderr nil nil nil 'replace)) + (delete-file remote-tmpstderr))))) ;; Return process. p))) @@ -3012,6 +3029,11 @@ the result will be a local, non-Tramp, file name." (if (tramp-get-env-with-u-option v) (setq env (append `("-u" ,elt) env)) (setq uenv (cons elt uenv)))))) + (setenv-internal + env "INSIDE_EMACS" + (concat (or (getenv "INSIDE_EMACS") emacs-version) + ",tramp:" tramp-version) + 'keep) (when env (setq command (format @@ -3028,7 +3050,7 @@ the result will be a local, non-Tramp, file name." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input 'nohop)) @@ -3059,8 +3081,7 @@ the result will be a local, non-Tramp, file name." (setcar (cdr destination) (expand-file-name (cadr destination))) (if (tramp-equal-remote default-directory (cadr destination)) ;; stderr is on the same remote host. - (setq stderr (with-parsed-tramp-file-name - (cadr destination) nil localname)) + (setq stderr (tramp-file-local-name (cadr destination))) ;; stderr must be copied to remote host. The temporary ;; file must be deleted after execution. (setq stderr (tramp-make-tramp-temp-file v) @@ -3078,13 +3099,12 @@ the result will be a local, non-Tramp, file name." ;; directory. (condition-case nil (unwind-protect - (setq ret - (if (tramp-send-command-and-check - v (format "cd %s && %s" - (tramp-shell-quote-argument localname) - command) - t t) - 0 1)) + (setq ret (tramp-send-command-and-check + v (format + "cd %s && %s" + (tramp-shell-quote-argument localname) command) + t t t)) + (unless (natnump ret) (setq ret 1)) ;; We should add the output anyway. (when outbuf (with-current-buffer outbuf @@ -3102,6 +3122,12 @@ the result will be a local, non-Tramp, file name." (kill-buffer (tramp-get-connection-buffer v)) (setq ret 1))) + ;; Handle signals. `process-file-return-signal-string' exists + ;; since Emacs 28.1. + (when (and (bound-and-true-p process-file-return-signal-string) + (natnump ret) (>= ret 128)) + (setq ret (nth (- ret 128) (tramp-get-signal-strings)))) + ;; Provide error file. (when tmpstderr (rename-file tmpstderr (cadr destination) t)) @@ -3122,7 +3148,7 @@ the result will be a local, non-Tramp, file name." (append (tramp-get-remote-path (tramp-dissect-file-name default-directory)) ;; The equivalent to `exec-directory'. - `(,(tramp-compat-file-local-name default-directory)))) + `(,(tramp-file-local-name (expand-file-name default-directory))))) (defun tramp-sh-handle-file-local-copy (filename) "Like `file-local-copy' for Tramp files." @@ -3236,7 +3262,8 @@ the result will be a local, non-Tramp, file name." #'write-region (list start end localname append 'no-message lockname)) - (let* ((modes (save-excursion (tramp-default-file-modes filename))) + (let* ((modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) ;; We use this to save the value of ;; `last-coding-system-used' after writing the tmp ;; file. At the end of the function, we set @@ -3258,7 +3285,8 @@ the result will be a local, non-Tramp, file name." ;; If `append' is non-nil, we copy the file locally, and let ;; the native `write-region' implementation do the job. - (when append (copy-file filename tmpfile 'ok)) + (when (and append (file-exists-p filename)) + (copy-file filename tmpfile 'ok)) ;; We say `no-message' here because we don't want the ;; visited file modtime data to be clobbered from the temp @@ -3354,9 +3382,8 @@ the result will be a local, non-Tramp, file name." loc-enc tmpfile t)) (tramp-error v 'file-error - (eval-when-compile - (concat "Cannot write to `%s', " - "local encoding command `%s' failed")) + (concat "Cannot write to `%s', " + "local encoding command `%s' failed") filename loc-enc)))) ;; Send buffer into remote decoding command which @@ -3401,9 +3428,8 @@ the result will be a local, non-Tramp, file name." (buffer-string)))) (tramp-error v 'file-error - (eval-when-compile - (concat "Couldn't write region to `%s'," - " decode using `%s' failed")) + (concat "Couldn't write region to `%s'," + " decode using `%s' failed") filename rem-dec))))) ;; Save exit. @@ -3413,9 +3439,8 @@ the result will be a local, non-Tramp, file name." (t (tramp-error v 'file-error - (eval-when-compile - (concat "Method `%s' should specify both encoding and " - "decoding command or an scp program")) + (concat "Method `%s' should specify both encoding and " + "decoding command or an scp program") method)))) ;; Make `last-coding-system-used' have the right value. @@ -3468,8 +3493,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-handle-vc-registered (file) "Like `vc-registered' for Tramp files." (when vc-handled-backends - (let ((tramp-message-show-message - (and (not revert-buffer-in-progress-p) tramp-message-show-message)) + (let ((inhibit-message (or revert-buffer-in-progress-p inhibit-message)) (temp-message (unless revert-buffer-in-progress-p ""))) (with-temp-message temp-message (with-parsed-tramp-file-name file nil @@ -3528,27 +3552,30 @@ the result will be a local, non-Tramp, file name." ;; calls shall be answered from the file cache. We unset ;; `process-file-side-effects' and `remote-file-name-inhibit-cache' ;; in order to keep the cache. - (let ((vc-handled-backends vc-handled-backends) + (let ((vc-handled-backends (copy-sequence vc-handled-backends)) remote-file-name-inhibit-cache process-file-side-effects) ;; Reduce `vc-handled-backends' in order to minimize ;; process calls. - (when (and (memq 'Bzr vc-handled-backends) - (boundp 'vc-bzr-program) + (when (and + (memq 'Bzr vc-handled-backends) + (or (not (require 'vc-bzr nil 'noerror)) (not (with-tramp-connection-property v vc-bzr-program (tramp-find-executable - v vc-bzr-program (tramp-get-remote-path v))))) + v vc-bzr-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Bzr vc-handled-backends))) - (when (and (memq 'Git vc-handled-backends) - (boundp 'vc-git-program) + (when (and + (memq 'Git vc-handled-backends) + (or (not (require 'vc-git nil 'noerror)) (not (with-tramp-connection-property v vc-git-program (tramp-find-executable - v vc-git-program (tramp-get-remote-path v))))) + v vc-git-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Git vc-handled-backends))) - (when (and (memq 'Hg vc-handled-backends) - (boundp 'vc-hg-program) + (when (and + (memq 'Hg vc-handled-backends) + (or (not (require 'vc-hg nil 'noerror)) (not (with-tramp-connection-property v vc-hg-program (tramp-find-executable - v vc-hg-program (tramp-get-remote-path v))))) + v vc-hg-program (tramp-get-remote-path v)))))) (setq vc-handled-backends (remq 'Hg vc-handled-backends))) ;; Run. (tramp-with-demoted-errors @@ -3559,10 +3586,9 @@ the result will be a local, non-Tramp, file name." (defun tramp-sh-file-name-handler (operation &rest args) "Invoke remote-shell Tramp file name handler. Fall back to normal file name handler if no Tramp handler exists." - (let ((fn (assoc operation tramp-sh-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sh-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;; This must be the last entry, because `identity' always matches. ;;;###tramp-autoload @@ -3614,13 +3640,11 @@ Fall back to normal file name handler if no Tramp handler exists." events (cond ((and (memq 'change flags) (memq 'attribute-change flags)) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,attrib,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,attrib,ignored")) ((memq 'change flags) - (eval-when-compile - (concat "create,modify,move,moved_from,moved_to,move_self," - "delete,delete_self,ignored"))) + (concat "create,modify,move,moved_from,moved_to,move_self," + "delete,delete_self,ignored")) ((memq 'attribute-change flags) "attrib,ignored")) sequence `(,command "-mq" "-e" ,events ,localname) ;; Make events a list of symbols. @@ -3762,12 +3786,11 @@ Fall back to normal file name handler if no Tramp handler exists." "ATTRIB CHANGED" "ATTRIBUTE_CHANGED" string)) (while (string-match - (eval-when-compile - (concat "^[\n\r]*" - "Directory Monitor Event:[\n\r]+" - "Child = \\([^\n\r]+\\)[\n\r]+" - "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" - "Event = \\([^[:blank:]]+\\)[\n\r]+")) + (concat "^[\n\r]*" + "Directory Monitor Event:[\n\r]+" + "Child = \\([^\n\r]+\\)[\n\r]+" + "\\(Other = \\([^\n\r]+\\)[\n\r]+\\)?" + "Event = \\([^[:blank:]]+\\)[\n\r]+") string) (let* ((file (match-string 1 string)) (file1 (match-string 3 string)) @@ -3803,10 +3826,9 @@ Fall back to normal file name handler if no Tramp handler exists." (dolist (line (split-string string "[\n\r]+" 'omit)) ;; Check, whether there is a problem. (unless (string-match - (eval-when-compile - (concat "^[^[:blank:]]+" - "[[:blank:]]+\\([^[:blank:]]+\\)" - "\\([[:blank:]]+\\([^\n\r]+\\)\\)?")) + (concat "^[^[:blank:]]+" + "[[:blank:]]+\\([^[:blank:]]+\\)" + "\\([[:blank:]]+\\([^\n\r]+\\)\\)?") line) (tramp-error proc 'file-notify-error "%s" line)) @@ -3842,11 +3864,10 @@ Fall back to normal file name handler if no Tramp handler exists." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" - "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "\\(?:^/[^[:space:]]*[[:space:]]\\)?" + "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (mapcar (lambda (d) (* d (tramp-get-connection-property v "df-blocksize" 0))) @@ -3915,13 +3936,16 @@ hosts, or files, disagree." (tramp-shell-quote-argument v1-localname) (tramp-shell-quote-argument v2-localname)))))) +(defconst tramp-sunos-unames (regexp-opt '("SunOS 5.10" "SunOS 5.11")) + "Regexp to determine remote SunOS.") + (defun tramp-find-executable (vec progname dirlist &optional ignore-tilde ignore-path) "Search for PROGNAME in $PATH and all directories mentioned in DIRLIST. First arg VEC specifies the connection, PROGNAME is the program to search for, and DIRLIST gives the list of directories to search. If IGNORE-TILDE is non-nil, directory names starting -with `~' will be ignored. If IGNORE-PATH is non-nil, searches +with \"~\" will be ignored. If IGNORE-PATH is non-nil, searches only in DIRLIST. Returns the absolute file name of PROGNAME, if found, and nil otherwise. @@ -3936,7 +3960,7 @@ This function expects to be in the right *tramp* buffer." ;; therefore. (unless (or ignore-path (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) + tramp-sunos-unames (tramp-get-connection-property vec "uname" ""))) (tramp-send-command vec (format "which \\%s | wc -w" progname)) (goto-char (point-min)) @@ -3947,19 +3971,18 @@ This function expects to be in the right *tramp* buffer." ;; Remove all ~/foo directories from dirlist. (let (newdl d) (while dirlist - (setq d (car dirlist)) - (setq dirlist (cdr dirlist)) + (setq d (car dirlist) + dirlist (cdr dirlist)) (unless (char-equal ?~ (aref d 0)) (setq newdl (cons d newdl)))) (setq dirlist (nreverse newdl)))) (tramp-send-command vec - (format (eval-when-compile - (concat "while read d; " - "do if test -x $d/%s && test -f $d/%s; " - "then echo tramp_executable $d/%s; " - "break; fi; done <<'%s'\n" - "%s\n%s")) + (format (concat "while read d; " + "do if test -x $d/%s && test -f $d/%s; " + "then echo tramp_executable $d/%s; " + "break; fi; done <<'%s'\n" + "%s\n%s") progname progname progname tramp-end-of-heredoc (string-join dirlist "\n") @@ -3983,21 +4006,22 @@ variable PATH." (format "PATH=%s; export PATH" (string-join (tramp-get-remote-path vec) ":"))) (pipe-buf - (or (with-tramp-connection-property vec "pipe-buf" - (tramp-send-command-and-read - vec "getconf PIPE_BUF / 2>/dev/null || echo nil" 'noerror)) - 4096)) + (with-tramp-connection-property vec "pipe-buf" + (tramp-send-command-and-read + vec "getconf PIPE_BUF / 2>/dev/null || echo 4096" 'noerror))) tmpfile) (tramp-message vec 5 "Setting $PATH environment variable") (if (< (length command) pipe-buf) (tramp-send-command vec command) ;; Use a temporary file. - (setq tmpfile - (tramp-make-tramp-file-name vec (tramp-make-tramp-temp-file vec))) - (write-region command nil tmpfile) - (tramp-send-command - vec (format ". %s" (tramp-compat-file-local-name tmpfile))) - (delete-file tmpfile)))) + (setq tmpfile (tramp-make-tramp-temp-file vec)) + (tramp-send-command vec (format + "cat >%s <<'%s'\n%s\n%s" + (tramp-shell-quote-argument tmpfile) + tramp-end-of-heredoc + command tramp-end-of-heredoc)) + (tramp-send-command vec (format ". %s" tmpfile)) + (tramp-send-command vec (format "rm -f %s" tmpfile))))) ;; ------------------------------------------------------------ ;; -- Communication with external shell -- @@ -4069,99 +4093,98 @@ file exists and nonzero exit status otherwise." (defun tramp-open-shell (vec shell) "Open shell SHELL." + ;; Find arguments for this shell. (with-tramp-progress-reporter vec 5 (format-message "Opening remote shell `%s'" shell) - ;; Find arguments for this shell. - (let ((extra-args (tramp-get-sh-extra-args shell))) - ;; doesn't know about and thus /bin/sh will display a strange - ;; prompt. For example, if $PS1 has "${CWD}" in the value, then - ;; ksh will display the current working directory but /bin/sh - ;; will display a dollar sign. The following command line sets - ;; $PS1 to a sane value, and works under Bourne-ish shells as - ;; well as csh-like shells. We also unset the variable $ENV - ;; because that is read by some sh implementations (eg, bash - ;; when called as sh) on startup; this way, we avoid the startup - ;; file clobbering $PS1. $PROMPT_COMMAND is another way to set - ;; the prompt in /bin/bash, it must be discarded as well. - ;; $HISTFILE is set according to `tramp-histfile-override'. - ;; $TERM and $INSIDE_EMACS set here to ensure they have the - ;; correct values when the shell starts, not just processes - ;; run within the shell. (Which processes include our - ;; initial probes to ensure the remote shell is usable.) - (tramp-send-command - vec (format - (eval-when-compile - (concat - "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " - "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s")) - tramp-terminal-type - emacs-version tramp-version ; INSIDE_EMACS - (or (getenv-internal "ENV" tramp-remote-process-environment) "") - (if (stringp tramp-histfile-override) - (format "HISTFILE=%s" - (tramp-shell-quote-argument tramp-histfile-override)) - (if tramp-histfile-override - "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" - "")) - (tramp-shell-quote-argument tramp-end-of-output) - shell (or extra-args "")) - t) - ;; Check proper HISTFILE setting. We give up when not working. - (when (and (stringp tramp-histfile-override) - (file-name-directory tramp-histfile-override)) - (tramp-barf-unless-okay - vec - (format - "(cd %s)" - (tramp-shell-quote-argument - (file-name-directory tramp-histfile-override))) - "`tramp-histfile-override' uses invalid file `%s'" - tramp-histfile-override))) + ;; It is useful to set the prompt in the following command because + ;; some people have a setting for $PS1 which /bin/sh doesn't know + ;; about and thus /bin/sh will display a strange prompt. For + ;; example, if $PS1 has "${CWD}" in the value, then ksh will + ;; display the current working directory but /bin/sh will display + ;; a dollar sign. The following command line sets $PS1 to a sane + ;; value, and works under Bourne-ish shells as well as csh-like + ;; shells. We also unset the variable $ENV because that is read + ;; by some sh implementations (eg, bash when called as sh) on + ;; startup; this way, we avoid the startup file clobbering $PS1. + ;; $PROMPT_COMMAND is another way to set the prompt in /bin/bash, + ;; it must be discarded as well. $HISTFILE is set according to + ;; `tramp-histfile-override'. $TERM and $INSIDE_EMACS set here to + ;; ensure they have the correct values when the shell starts, not + ;; just processes run within the shell. (Which processes include + ;; our initial probes to ensure the remote shell is usable.) + (tramp-send-command + vec (format + (concat + "exec env TERM='%s' INSIDE_EMACS='%s,tramp:%s' " + "ENV=%s %s PROMPT_COMMAND='' PS1=%s PS2='' PS3='' %s %s") + tramp-terminal-type + (or (getenv "INSIDE_EMACS") emacs-version) tramp-version + (or (getenv-internal "ENV" tramp-remote-process-environment) "") + (if (stringp tramp-histfile-override) + (format "HISTFILE=%s" + (tramp-shell-quote-argument tramp-histfile-override)) + (if tramp-histfile-override + "HISTFILE='' HISTFILESIZE=0 HISTSIZE=0" + "")) + (tramp-shell-quote-argument tramp-end-of-output) + shell (or (tramp-get-sh-extra-args shell) "")) + t) + ;; Check proper HISTFILE setting. We give up when not working. + (when (and (stringp tramp-histfile-override) + (file-name-directory tramp-histfile-override)) + (tramp-barf-unless-okay + vec + (format + "(cd %s)" + (tramp-shell-quote-argument + (file-name-directory tramp-histfile-override))) + "`tramp-histfile-override' uses invalid file `%s'" + tramp-histfile-override)) (tramp-set-connection-property (tramp-get-connection-process vec) "remote-shell" shell))) (defun tramp-find-shell (vec) "Open a shell on the remote host which groks tilde expansion." - (with-current-buffer (tramp-get-buffer vec) - (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) - shell) - (setq shell - (with-tramp-connection-property vec "remote-shell" - ;; CCC: "root" does not exist always, see my QNAP TS-459. - ;; Which check could we apply instead? - (tramp-send-command vec "echo ~root" t) - (if (or (string-match-p "^~root$" (buffer-string)) - ;; The default shell (ksh93) of OpenSolaris and - ;; Solaris is buggy. We've got reports for - ;; "SunOS 5.10" and "SunOS 5.11" so far. - (string-match-p - (eval-when-compile - (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" ""))) - - (or (tramp-find-executable - vec "bash" (tramp-get-remote-path vec) t t) - (tramp-find-executable - vec "ksh" (tramp-get-remote-path vec) t t) - ;; Maybe it works at least for some other commands. - (prog1 - default-shell - (tramp-message - vec 2 - (eval-when-compile + ;; If we are in `make-process', we don't need another shell. + (unless (tramp-get-connection-property vec "process-name" nil) + (with-current-buffer (tramp-get-buffer vec) + (let ((default-shell (tramp-get-method-parameter vec 'tramp-remote-shell)) + shell) + (setq shell + (with-tramp-connection-property vec "remote-shell" + ;; CCC: "root" does not exist always, see my QNAP + ;; TS-459. Which check could we apply instead? + (tramp-send-command vec "echo ~root" t) + (if (or (string-match-p "^~root$" (buffer-string)) + ;; The default shell (ksh93) of OpenSolaris + ;; and Solaris is buggy. We've got reports + ;; for "SunOS 5.10" and "SunOS 5.11" so far. + (string-match-p + tramp-sunos-unames + (tramp-get-connection-property vec "uname" ""))) + + (or (tramp-find-executable + vec "bash" (tramp-get-remote-path vec) t t) + (tramp-find-executable + vec "ksh" (tramp-get-remote-path vec) t t) + ;; Maybe it works at least for some other commands. + (prog1 + default-shell + (tramp-message + vec 2 (concat "Couldn't find a remote shell which groks tilde " - "expansion, using `%s'")) - default-shell))) + "expansion, using `%s'") + default-shell))) - default-shell))) + default-shell))) - ;; Open a new shell if needed. - (unless (string-equal shell default-shell) - (tramp-message - vec 5 "Starting remote shell `%s' for tilde expansion" shell) - (tramp-open-shell vec shell))))) + ;; Open a new shell if needed. + (unless (string-equal shell default-shell) + (tramp-message + vec 5 "Starting remote shell `%s' for tilde expansion" shell) + (tramp-open-shell vec shell)))))) ;; Utility functions. @@ -4187,9 +4210,16 @@ process to set up. VEC specifies the connection." (let ((tramp-end-of-output tramp-initial-end-of-output) (case-fold-search t)) (tramp-open-shell vec (tramp-get-method-parameter vec 'tramp-remote-shell)) + (tramp-message vec 5 "Setting up remote shell environment") + + ;; Disable line editing. + (tramp-send-command vec "set +o vi +o emacs" t) + + ;; Dump option settings in the traces. + (when (>= tramp-verbose 9) + (tramp-send-command vec "set -o" t)) ;; Disable echo expansion. - (tramp-message vec 5 "Setting up remote shell environment") (tramp-send-command vec "stty -inlcr -onlcr -echo kill '^U' erase '^H'" t) ;; Check whether the echo has really been disabled. Some @@ -4216,11 +4246,15 @@ process to set up. VEC specifies the connection." ;; connection properties. We start again with ;; `tramp-maybe-open-connection', it will be caught there. (tramp-message vec 5 "Checking system information") - (let ((old-uname (tramp-get-connection-property vec "uname" nil)) - (uname - (tramp-set-connection-property - vec "uname" - (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\"")))) + (let* ((old-uname (tramp-get-connection-property vec "uname" nil)) + (uname + ;; If we are in `make-process', we don't need to recompute. + (if (and old-uname + (tramp-get-connection-property vec "process-name" nil)) + old-uname + (tramp-set-connection-property + vec "uname" + (tramp-send-command-and-read vec "echo \\\"`uname -sr`\\\""))))) (when (and (stringp old-uname) (not (string-equal old-uname uname))) (tramp-message vec 3 @@ -4259,8 +4293,6 @@ process to set up. VEC specifies the connection." (tramp-message vec 5 "Setting coding system to `%s' and `%s'" cs-decode cs-encode))) - (tramp-send-command vec "set +o vi +o emacs" t) - ;; Check whether the remote host suffers from buggy ;; `send-process-string'. This is known for FreeBSD (see comment ;; in `send_process', file process.c). I've tested sending 624 @@ -4383,7 +4415,7 @@ and end of region, and are expected to replace the region contents with the encoded or decoded results, respectively.") (defconst tramp-remote-coding-commands - `((b64 "base64" "base64 -d -i") + '((b64 "base64" "base64 -d -i") ;; "-i" is more robust with older base64 from GNU coreutils. ;; However, I don't know whether all base64 versions do supports ;; this option. @@ -4394,8 +4426,9 @@ with the encoded or decoded results, respectively.") (b64 "recode data..base64" "recode base64..data") (b64 tramp-perl-encode-with-module tramp-perl-decode-with-module) (b64 tramp-perl-encode tramp-perl-decode) - ;; This is painful slow, so we put it on the end. - (b64 tramp-awk-encode tramp-awk-decode ,tramp-awk-coding-test) + ;; These are painfully slow, so we put them on the end. + (b64 tramp-hexdump-awk-encode tramp-awk-decode) + (b64 tramp-od-awk-encode tramp-awk-decode) (uu "uuencode xxx" "uudecode -o /dev/stdout" "test -c /dev/stdout") (uu "uuencode xxx" "uudecode -o -") (uu "uuencode xxx" "uudecode -p") @@ -4421,6 +4454,8 @@ Perl or Shell implementation for this functionality. This program will be transferred to the remote host, and it is available as shell function with the same name. A \"%t\" format specifier in the variable value denotes a temporary file. +\"%a\", \"%h\" and \"%o\" format specifiers are replaced by the +respective `awk', `hexdump' and `od' commands. The optional TEST command can be used for further tests, whether ENCODING and DECODING are applicable.") @@ -4439,8 +4474,8 @@ Goes through the list `tramp-local-coding-commands' and (catch 'wont-work-local (let ((format (nth 0 litem)) (remote-commands tramp-remote-coding-commands)) - (setq loc-enc (nth 1 litem)) - (setq loc-dec (nth 2 litem)) + (setq loc-enc (nth 1 litem) + loc-dec (nth 2 litem)) ;; If the local encoder or decoder is a string, the ;; corresponding command has to work locally. (if (not (stringp loc-enc)) @@ -4462,20 +4497,15 @@ Goes through the list `tramp-local-coding-commands' and (setq ritem (pop remote-commands)) (catch 'wont-work-remote (when (equal format (nth 0 ritem)) - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq rem-test (nth 3 ritem)) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + rem-test (nth 3 ritem)) ;; Check the remote test command if exists. (when (stringp rem-test) (tramp-message vec 5 "Checking remote test command `%s'" rem-test) (unless (tramp-send-command-and-check vec rem-test t) (throw 'wont-work-remote nil))) - ;; Check if remote perl exists when necessary. - (when (and (symbolp rem-enc) - (string-match-p "perl" (symbol-name rem-enc)) - (not (tramp-get-remote-perl vec))) - (throw 'wont-work-remote nil)) ;; Check if remote encoding and decoding commands can be ;; called remotely with null input and output. This makes ;; sure there are no syntax errors and the command is really @@ -4485,10 +4515,36 @@ Goes through the list `tramp-local-coding-commands' and ;; redirecting "mimencode" output to /dev/null, then as root ;; it might change the permissions of /dev/null! (unless (stringp rem-enc) - (let ((name (symbol-name rem-enc))) + (let ((name (symbol-name rem-enc)) + (value (symbol-value rem-enc))) + ;; Check if remote perl exists when necessary. + (and (string-match-p "perl" name) + (not (tramp-get-remote-perl vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote awk exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%a" value) + (not (tramp-get-remote-awk vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote hexdump exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%h" value) + (not (tramp-get-remote-hexdump vec)) + (throw 'wont-work-remote nil)) + ;; Check if remote od exists when necessary. + (and (string-match-p "\\(^\\|[^%]\\)%o" value) + (not (tramp-get-remote-od vec)) + (throw 'wont-work-remote nil)) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) - (tramp-maybe-send-script vec (symbol-value rem-enc) name) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) + (tramp-maybe-send-script vec value name) (setq rem-enc name))) (tramp-message vec 5 @@ -4503,17 +4559,22 @@ Goes through the list `tramp-local-coding-commands' and tmpfile) (while (string-match "-" name) (setq name (replace-match "_" nil t name))) + (when (string-match-p "\\(^\\|[^%]\\)%[aho]" value) + (setq value + (format-spec + value + (format-spec-make + ?a (tramp-get-remote-awk vec) + ?h (tramp-get-remote-hexdump vec) + ?o (tramp-get-remote-od vec))) + value (replace-regexp-in-string "%" "%%" value))) (when (string-match-p "\\(^\\|[^%]\\)%t" value) - (setq tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-get-remote-tmpdir vec))) + (setq tmpfile (tramp-make-tramp-temp-name vec) value (format-spec value (format-spec-make - ?t (tramp-compat-file-local-name tmpfile))))) + ?t (tramp-file-local-name tmpfile))))) (tramp-maybe-send-script vec value name) (setq rem-dec name))) (tramp-message @@ -4531,9 +4592,9 @@ Goes through the list `tramp-local-coding-commands' and (throw 'wont-work-remote nil))) ;; `rem-enc' and `rem-dec' could be a string meanwhile. - (setq rem-enc (nth 1 ritem)) - (setq rem-dec (nth 2 ritem)) - (setq found t))))))) + (setq rem-enc (nth 1 ritem) + rem-dec (nth 2 ritem) + found t))))))) (when found ;; Set connection properties. Since the commands are risky @@ -4796,8 +4857,8 @@ If there is just some editing, retry it after 5 seconds." vec 5 "Cannot timeout session, trying it again in %s seconds." 5) (run-at-time 5 nil 'tramp-timeout-session vec)) (tramp-message - vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'localname)) - (tramp-cleanup-connection vec 'keep-debug))) + vec 3 "Timeout session %s" (tramp-make-tramp-file-name vec 'noloc)) + (tramp-cleanup-connection vec 'keep-debug nil 'keep-processes))) (defun tramp-maybe-open-connection (vec) "Maybe open a connection VEC. @@ -4818,11 +4879,8 @@ connection if a previous connection has died for some reason." (not (tramp-file-name-equal-p vec (car tramp-current-connection))) (time-less-p - ;; `current-time' can be removed once we get rid of Emacs 24. - (time-since (or (cdr tramp-current-connection) (current-time))) - ;; `seconds-to-time' can be removed once we get rid - ;; of Emacs 24. - (seconds-to-time (or tramp-connection-min-time-diff 0)))) + (time-since (cdr tramp-current-connection)) + (or tramp-connection-min-time-diff 0))) (throw 'suppress 'suppress)) ;; If too much time has passed since last command was sent, look @@ -4833,11 +4891,9 @@ connection if a previous connection has died for some reason." ;; try to send a command from time to time, then look again ;; whether the process is really alive. (condition-case nil - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) (process-live-p p)) (tramp-send-command vec "echo are you awake" t t) (unless (and (process-live-p p) @@ -4951,11 +5007,8 @@ connection if a previous connection has died for some reason." ;; we cannot use `tramp-get-connection-process'. (tmpfile (with-tramp-connection-property - (get-process (tramp-buffer-name vec)) "temp-file" - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (tramp-get-process vec) "temp-file" + (tramp-compat-make-temp-name))) spec r-shell) ;; Add arguments for asynchronous processes. @@ -5116,7 +5169,7 @@ function waits for output unless NOOUTPUT is set." found))) (defun tramp-send-command-and-check - (vec command &optional subshell dont-suppress-err) + (vec command &optional subshell dont-suppress-err exit-status) "Run COMMAND and check its exit status. Send `echo $?' along with the COMMAND for checking the exit status. If COMMAND is nil, just send `echo $?'. Return t if the exit @@ -5124,7 +5177,9 @@ status is 0, and nil otherwise. If the optional argument SUBSHELL is non-nil, the command is executed in a subshell, ie surrounded by parentheses. If -DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." +DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null. +Optional argument EXIT-STATUS, if non-nil, triggers the return of +the exit status." (tramp-send-command vec (concat (if subshell "( " "") @@ -5133,12 +5188,14 @@ DONT-SUPPRESS-ERR is non-nil, stderr won't be sent to /dev/null." "echo tramp_exit_status $?" (if subshell " )" ""))) (with-current-buffer (tramp-get-connection-buffer vec) - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error vec 'file-error "Couldn't find exit status of `%s'" command)) (skip-chars-forward "^ ") (prog1 - (zerop (read (current-buffer))) + (if exit-status + (read (current-buffer)) + (zerop (read (current-buffer)))) (let ((inhibit-read-only t)) (delete-region (match-beginning 0) (point-max)))))) @@ -5171,7 +5228,10 @@ raises an error." command marker (buffer-string)))))) ;; Read the expression. (condition-case nil - (prog1 (read (current-buffer)) + (prog1 + (let ((signal-hook-function + (unless noerror signal-hook-function))) + (read (current-buffer))) ;; Error handling. (when (re-search-forward "\\S-" (point-at-eol) t) (error nil))) @@ -5324,7 +5384,7 @@ Nonexistent directories are removed from spec." ;; cache the result for the session only. Otherwise, the ;; result is cached persistently. (if (memq 'tramp-own-remote-path tramp-remote-path) - (tramp-get-connection-process vec) + (tramp-get-process vec) vec) "remote-path" (let* ((remote-path (copy-tree tramp-remote-path)) @@ -5532,8 +5592,7 @@ Nonexistent directories are removed from spec." ;; stat on Solaris is buggy. We've got reports for "SunOS 5.10" ;; and "SunOS 5.11" so far. (unless (string-match-p - (eval-when-compile (regexp-opt '("SunOS 5.10" "SunOS 5.11"))) - (tramp-get-connection-property vec "uname" "")) + tramp-sunos-unames (tramp-get-connection-property vec "uname" "")) (tramp-message vec 5 "Finding a suitable `stat' command") (let ((result (tramp-find-executable vec "stat" (tramp-get-remote-path vec))) @@ -5579,10 +5638,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." (tramp-message vec 5 "Finding a suitable `touch' command") (let ((result (tramp-find-executable vec "touch" (tramp-get-remote-path vec))) - (tmpfile - (make-temp-name - (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))))) + (tmpfile (tramp-make-tramp-temp-name vec))) ;; Busyboxes do support the "-t" option only when they have been ;; built with the DESKTOP config option. Let's check it. (when result @@ -5594,7 +5650,7 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "%s -t %s %s" result (format-time-string "%Y%m%d%H%M.%S") - (tramp-compat-file-local-name tmpfile)))) + (tramp-file-local-name tmpfile)))) (delete-file tmpfile)) result))) @@ -5697,27 +5753,6 @@ This command is returned only if `delete-by-moving-to-trash' is non-nil." "import os; print (os.getuid())" "import os, pwd; print ('\\\"' + pwd.getpwuid(os.getuid())[0] + '\\\"')")))) -(defun tramp-get-remote-uid (vec id-format) - "The uid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-uid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-uid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-uid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) - (defun tramp-get-remote-gid-with-id (vec id-format) "Implement `tramp-get-remote-gid' for Tramp files using `id'." (tramp-send-command-and-read @@ -5748,26 +5783,59 @@ ID-FORMAT valid values are `string' and `integer'." "import os; print (os.getgid())" "import os, grp; print ('\\\"' + grp.getgrgid(os.getgid())[0] + '\\\"')")))) -(defun tramp-get-remote-gid (vec id-format) - "The gid of the remote connection VEC, in ID-FORMAT. -ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (let ((res - (ignore-errors - (cond - ((tramp-get-remote-id vec) - (tramp-get-remote-gid-with-id vec id-format)) - ((tramp-get-remote-perl vec) - (tramp-get-remote-gid-with-perl vec id-format)) - ((tramp-get-remote-python vec) - (tramp-get-remote-gid-with-python vec id-format)))))) - ;; Ensure there is a valid result. - (cond - ((and (equal id-format 'integer) (not (integerp res))) - tramp-unknown-id-integer) - ((and (equal id-format 'string) (not (stringp res))) - tramp-unknown-id-string) - (t res))))) +(defun tramp-get-remote-busybox (vec) + "Determine remote `busybox' command." + (with-tramp-connection-property vec "busybox" + (tramp-message vec 5 "Finding a suitable `busybox' command") + (tramp-find-executable vec "busybox" (tramp-get-remote-path vec)))) + +(defun tramp-get-remote-awk (vec) + "Determine remote `awk' command." + (with-tramp-connection-property vec "awk" + (tramp-message vec 5 "Finding a suitable `awk' command") + (or (tramp-find-executable vec "awk" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "awk"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " {} </dev/null")) + command))))) + +(defun tramp-get-remote-hexdump (vec) + "Determine remote `hexdump' command." + (with-tramp-connection-property vec "hexdump" + (tramp-message vec 5 "Finding a suitable `hexdump' command") + (or (tramp-find-executable vec "hexdump" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "hexdump"))) + (and busybox + (tramp-send-command-and-check vec (concat command " </dev/null")) + command))))) + +(defun tramp-get-remote-od (vec) + "Determine remote `od' command." + (with-tramp-connection-property vec "od" + (tramp-message vec 5 "Finding a suitable `od' command") + (or (tramp-find-executable vec "od" (tramp-get-remote-path vec)) + (let* ((busybox (tramp-get-remote-busybox vec)) + (command (format "%s %s" busybox "od"))) + (and busybox + (tramp-send-command-and-check + vec (concat command " -A n </dev/null")) + command))))) + +(defun tramp-get-remote-chmod-h (vec) + "Check whether remote `chmod' supports nofollow argument." + (with-tramp-connection-property vec "chmod-h" + (tramp-message vec 5 "Finding a suitable `chmod' command with nofollow") + (let ((tmpfile (tramp-make-tramp-temp-name vec))) + (prog1 + (tramp-send-command-and-check + vec + (format + "ln -s foo %s && chmod -h %s 0777" + (tramp-file-local-name tmpfile) (tramp-file-local-name tmpfile))) + (delete-file tmpfile))))) (defun tramp-get-env-with-u-option (vec) "Check, whether the remote `env' command supports the -u option." @@ -5786,10 +5854,9 @@ the length of the file to be compressed. If no corresponding command is found, nil is returned." (when (and (integerp tramp-inline-compress-start-size) (> size tramp-inline-compress-start-size)) - (with-tramp-connection-property (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-compress vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil)))) + (tramp-get-connection-property (tramp-get-process vec) prop nil)))) (defun tramp-get-inline-coding (vec prop size) "Return the coding command related to PROP. @@ -5807,11 +5874,9 @@ function cell is returned to be applied on a buffer." ;; no inline coding is found. (ignore-errors (let ((coding - (with-tramp-connection-property - (tramp-get-connection-process vec) prop + (with-tramp-connection-property (tramp-get-process vec) prop (tramp-find-inline-encoding vec) - (tramp-get-connection-property - (tramp-get-connection-process vec) prop nil))) + (tramp-get-connection-property (tramp-get-process vec) prop nil))) (prop1 (if (string-match-p "encoding" prop) "inline-compress" "inline-decompress")) compress) @@ -5889,9 +5954,6 @@ function cell is returned to be applied on a buffer." ;; likely to produce long command lines, and some shells choke on ;; long command lines. ;; -;; * Don't search for perl5 and perl. Instead, only search for perl and -;; then look if it's the right version (with `perl -v'). -;; ;; * When editing a remote CVS controlled file as a different user, VC ;; gets confused about the file locking status. Try to find out why ;; the workaround doesn't work. diff --git a/lisp/net/tramp-smb.el b/lisp/net/tramp-smb.el index bf77ab9dee8..1b6af2a2e33 100644 --- a/lisp/net/tramp-smb.el +++ b/lisp/net/tramp-smb.el @@ -75,12 +75,23 @@ ;;;###tramp-autoload (defcustom tramp-smb-conf "/dev/null" - "Path of the smb.conf file. -If it is nil, no smb.conf will be added to the `tramp-smb-program' + "Path of the \"smb.conf\" file. +If it is nil, no \"smb.conf\" will be added to the `tramp-smb-program' call, letting the SMB client use the default one." :group 'tramp :type '(choice (const nil) (file :must-match t))) +;;;###tramp-autoload +(defcustom tramp-smb-options nil + "List of additional options. +They are added to the `tramp-smb-program' call via \"--option '...'\". + +For example, if the deprecated SMB1 protocol shall be used, add to +this variable (\"client min protocol=NT1\") ." + :group 'tramp + :type '(repeat string) + :version "28.1") + (defvar tramp-smb-version nil "Version string of the SMB client.") @@ -135,6 +146,7 @@ call, letting the SMB client use the default one." "NT_STATUS_HOST_UNREACHABLE" "NT_STATUS_IMAGE_ALREADY_LOADED" "NT_STATUS_INVALID_LEVEL" + "NT_STATUS_INVALID_PARAMETER" "NT_STATUS_INVALID_PARAMETER_MIX" "NT_STATUS_IO_TIMEOUT" "NT_STATUS_LOGON_FAILURE" @@ -281,6 +293,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . tramp-smb-handle-start-file-process) (substitute-in-file-name . tramp-smb-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . ignore) + (tramp-get-remote-uid . ignore) (tramp-set-file-uid-gid . ignore) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -329,10 +343,9 @@ This can be used to disable echo etc." "Invoke the SMB related OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-smb-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-smb-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (unless (memq system-type '(cygwin windows-nt)) @@ -420,16 +433,12 @@ pass to the OPERATION." v tramp-file-missing "Copying directory" "No such file or directory" dirname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-already-exists newname)) (cond ;; We must use a local temporary directory. ((and t1 t2) - (let ((tmpdir - (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory))))) + (let ((tmpdir (tramp-compat-make-temp-name))) (unwind-protect (progn (make-directory tmpdir) @@ -457,11 +466,9 @@ pass to the OPERATION." (localname (file-name-as-directory (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v)))) - (tmpdir (make-temp-name - (expand-file-name - tramp-temp-name-prefix - (tramp-compat-temporary-file-directory)))) - (args (list (concat "//" host "/" share) "-E"))) + (tmpdir (tramp-compat-make-temp-name)) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -471,6 +478,10 @@ pass to the OPERATION." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (if t1 ;; Source is remote. @@ -539,10 +550,11 @@ pass to the OPERATION." ;; Handle KEEP-DATE argument. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes dirname)))) + (file-attributes dirname)) + (unless ok-if-already-exists 'nofollow))) ;; Set the mode. (unless keep-date @@ -581,47 +593,47 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." tramp-file-missing "Copying file" "No such file or directory" filename)) - (let ((tmpfile (file-local-copy filename))) - (if tmpfile - ;; Remote filename. - (condition-case err - (rename-file tmpfile newname ok-if-already-exists) - ((error quit) - (delete-file tmpfile) - (signal (car err) (cdr err)))) - - ;; Remote newname. + (if-let ((tmpfile (file-local-copy filename))) + ;; Remote filename. + (condition-case err + (rename-file tmpfile newname ok-if-already-exists) + ((error quit) + (delete-file tmpfile) + (signal (car err) (cdr err)))) + + ;; Remote newname. + (when (and (file-directory-p newname) + (directory-name-p newname)) + (setq newname + (expand-file-name (file-name-nondirectory filename) newname))) + + (with-parsed-tramp-file-name newname nil + (when (and (not ok-if-already-exists) (file-exists-p newname)) + (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (tramp-compat-directory-name-p newname)) - (setq newname - (expand-file-name (file-name-nondirectory filename) newname))) + (not (directory-name-p newname))) + (tramp-error v 'file-error "File is a directory %s" newname)) - (with-parsed-tramp-file-name newname nil - (when (and (not ok-if-already-exists) (file-exists-p newname)) - (tramp-error v 'file-already-exists newname)) - (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) - (tramp-error v 'file-error "File is a directory %s" newname)) - - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) - (unless (tramp-smb-get-share v) - (tramp-error - v 'file-error "Target `%s' must contain a share name" newname)) - (unless (tramp-smb-send-command - v (format "put \"%s\" \"%s\"" - (tramp-compat-file-name-unquote filename) - (tramp-smb-get-localname v))) - (tramp-error - v 'file-error "Cannot copy `%s' to `%s'" filename newname)))))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (tramp-smb-get-share v) + (tramp-error + v 'file-error "Target `%s' must contain a share name" newname)) + (unless (tramp-smb-send-command + v (format "put \"%s\" \"%s\"" + (tramp-compat-file-name-unquote filename) + (tramp-smb-get-localname v))) + (tramp-error + v 'file-error "Cannot copy `%s' to `%s'" filename newname))))) ;; KEEP-DATE handling. (when keep-date - (set-file-times + (tramp-compat-set-file-times newname (tramp-compat-file-attribute-modification-time - (file-attributes filename)))))) + (file-attributes filename)) + (unless ok-if-already-exists 'nofollow))))) (defun tramp-smb-handle-delete-directory (directory &optional recursive _trash) "Like `delete-directory' for Tramp files." @@ -692,11 +704,11 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (delete nil (mapcar (lambda (x) (when (string-match-p match x) x)) result)))) - ;; Append directory. + ;; Prepend directory. (when full (setq result (mapcar - (lambda (x) (format "%s/%s" directory x)) + (lambda (x) (format "%s/%s" (directory-file-name directory) x)) result))) ;; Sort them if necessary. (unless nosort (setq result (sort result #'string-lessp))) @@ -760,7 +772,8 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (let* ((share (tramp-smb-get-share v)) (localname (replace-regexp-in-string "\\\\" "/" (tramp-smb-get-localname v))) - (args (list (concat "//" host "/" share) "-E"))) + (args (list (concat "//" host "/" share) "-E")) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -770,6 +783,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -858,23 +875,31 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (while (not (eobp)) (cond ((looking-at - "Size:\\s-+\\([0-9]+\\)\\s-+Blocks:\\s-+[0-9]+\\s-+\\(\\w+\\)") + (concat + "Size:\\s-+\\([[:digit:]]+\\)\\s-+" + "Blocks:\\s-+[[:digit:]]+\\s-+\\(\\w+\\)")) (setq size (string-to-number (match-string 1)) id (if (string-equal "directory" (match-string 2)) t (if (string-equal "symbolic" (match-string 2)) "")))) ((looking-at - "Inode:\\s-+\\([0-9]+\\)\\s-+Links:\\s-+\\([0-9]+\\)") + "Inode:\\s-+\\([[:digit:]]+\\)\\s-+Links:\\s-+\\([[:digit:]]+\\)") (setq inode (string-to-number (match-string 1)) link (string-to-number (match-string 2)))) ((looking-at - "Access:\\s-+([0-9]+/\\(\\S-+\\))\\s-+Uid:\\s-+\\([0-9]+\\)\\s-+Gid:\\s-+\\([0-9]+\\)") + (concat + "Access:\\s-+([[:digit:]]+/\\(\\S-+\\))\\s-+" + "Uid:\\s-+\\([[:digit:]]+\\)\\s-+" + "Gid:\\s-+\\([[:digit:]]+\\)")) (setq mode (match-string 1) uid (if (equal id-format 'string) (match-string 2) (string-to-number (match-string 2))) gid (if (equal id-format 'string) (match-string 3) (string-to-number (match-string 3))))) ((looking-at - "Access:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Access:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq atime (encode-time (string-to-number (match-string 6)) ;; sec @@ -884,7 +909,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Modify:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Modify:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq mtime (encode-time (string-to-number (match-string 6)) ;; sec @@ -894,7 +922,10 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (string-to-number (match-string 2)) ;; month (string-to-number (match-string 1))))) ;; year ((looking-at - "Change:\\s-+\\([0-9]+\\)-\\([0-9]+\\)-\\([0-9]+\\)\\s-+\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)") + (concat + "Change:\\s-+" + "\\([[:digit:]]+\\)-\\([[:digit:]]+\\)-\\([[:digit:]]+\\)\\s-+" + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)")) (setq ctime (encode-time (string-to-number (match-string 6)) ;; sec @@ -970,10 +1001,9 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - " blocks of size \\([[:digit:]]+\\)" - "\\. \\([[:digit:]]+\\) blocks available"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + " blocks of size \\([[:digit:]]+\\)" + "\\. \\([[:digit:]]+\\) blocks available")) (setq blocksize (string-to-number (match-string 2)) total (* blocksize (string-to-number (match-string 1))) avail (* blocksize (string-to-number (match-string 3))))) @@ -1003,7 +1033,7 @@ PRESERVE-UID-GID and PRESERVE-EXTENDED-ATTRIBUTES are completely ignored." (setq filename (expand-file-name filename)) (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) (if full-directory-p @@ -1188,9 +1218,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -1244,7 +1272,7 @@ component is used as the target of the symlink." (setq infile (expand-file-name infile)) (if (tramp-equal-remote default-directory infile) ;; INFILE is on the same remote host. - (setq input (with-parsed-tramp-file-name infile nil localname)) + (setq input (tramp-file-local-name infile)) ;; INFILE must be copied to remote host. (setq input (tramp-make-tramp-temp-file v) tmpinput (tramp-make-tramp-file-name v input)) @@ -1357,7 +1385,7 @@ component is used as the target of the symlink." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (with-tramp-progress-reporter @@ -1414,7 +1442,8 @@ component is used as the target of the symlink." "\\\\" "/" (tramp-smb-get-localname v))) (args (list (concat "//" host "/" share) "-E" "-S" (replace-regexp-in-string - "\n" "," acl-string)))) + "\n" "," acl-string))) + (options tramp-smb-options)) (if (not (zerop (length user))) (setq args (append args (list "-U" user))) @@ -1424,6 +1453,10 @@ component is used as the target of the symlink." (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (setq args (append args (list (tramp-unquote-shell-quote-argument localname) @@ -1454,7 +1487,7 @@ component is used as the target of the symlink." ;; This is meant for traces, and returning from the ;; function. No error is propagated outside, due to ;; the `ignore-errors' closure. - (unless (tramp-search-regexp "tramp_exit_status [0-9]+") + (unless (tramp-search-regexp "tramp_exit_status [[:digit:]]+") (tramp-error v 'file-error "Couldn't find exit status of `%s'" tramp-smb-acl-program)) @@ -1468,15 +1501,17 @@ component is used as the target of the symlink." (tramp-flush-connection-property v "process-name") (tramp-flush-connection-property v "process-buffer"))))))) -(defun tramp-smb-handle-set-file-modes (filename mode) +(defun tramp-smb-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (when (tramp-smb-get-cifs-capabilities v) - (tramp-flush-file-properties v localname) - (unless (tramp-smb-send-command - v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename))))) + ;; smbclient chmod does not support nofollow. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (when (tramp-smb-get-cifs-capabilities v) + (tramp-flush-file-properties v localname) + (unless (tramp-smb-send-command + v (format "chmod \"%s\" %o" (tramp-smb-get-localname v) mode)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename)))))) ;; We use BUFFER also as connection buffer during setup. Because of ;; this, its original contents must be saved, and restored once @@ -1557,9 +1592,6 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (format "File %s exists; overwrite anyway? " filename))))) (tramp-error v 'file-already-exists filename)) - ;; We must also flush the cache of the directory, because - ;; `file-attributes' reads the values from there. - (tramp-flush-file-properties v localname) (let ((curbuf (current-buffer)) (tmpfile (tramp-compat-make-temp-file filename))) (when (and append (file-exists-p filename)) @@ -1579,6 +1611,10 @@ errors for shares like \"C$/\", which are common in Microsoft Windows." (tramp-error v 'file-error "Cannot write `%s'" filename)) (delete-file tmpfile))) + ;; We must also flush the cache of the directory, because + ;; `file-attributes' reads the values from there. + (tramp-flush-file-properties v localname) + (unless (equal curbuf (current-buffer)) (tramp-error v 'file-error @@ -1696,21 +1732,21 @@ Result is a list of (LOCALNAME MODE SIZE MONTH DAY TIME YEAR)." ;; Entries provided by smbclient DIR aren't fully regular. ;; They should have the format ;; -;; \s-\{2,2} - leading spaces +;; \s-\{2,2\} - leading spaces ;; \S-\(.*\S-\)\s-* - file name, 30 chars, left bound ;; \s-+[ADHRSV]* - permissions, 7 chars, right bound ;; \s- - space delimiter -;; \s-+[0-9]+ - size, 8 chars, right bound +;; \s-+[[:digit:]]+ - size, 8 chars, right bound ;; \s-\{2,2\} - space delimiter ;; \w\{3,3\} - weekday ;; \s- - space delimiter ;; \w\{3,3\} - month ;; \s- - space delimiter -;; [ 12][0-9] - day +;; [ 12][[:digit:]] - day ;; \s- - space delimiter -;; [0-9]\{2,2\}:[0-9]\{2,2\}:[0-9]\{2,2\} - time +;; [[:digit:]]\{2,2\}:[[:digit:]]\{2,2\}:[[:digit:]]\{2,2\} - time ;; \s- - space delimiter -;; [0-9]\{4,4\} - year +;; [[:digit:]]\{4,4\} - year ;; ;; samba/src/client.c (http://samba.org/doxygen/samba/client_8c-source.html) ;; has function display_finfo: @@ -1758,13 +1794,14 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-block nil ;; year. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq year (string-to-number (match-string 1 line)) line (substring line 0 -5)) (cl-return)) ;; time. - (if (string-match "\\([0-9]+\\):\\([0-9]+\\):\\([0-9]+\\)$" line) + (if (string-match + "\\([[:digit:]]+\\):\\([[:digit:]]+\\):\\([[:digit:]]+\\)$" line) (setq hour (string-to-number (match-string 1 line)) min (string-to-number (match-string 2 line)) sec (string-to-number (match-string 3 line)) @@ -1772,7 +1809,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; day. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (setq day (string-to-number (match-string 1 line)) line (substring line 0 -3)) (cl-return)) @@ -1789,7 +1826,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (cl-return)) ;; size. - (if (string-match "\\([0-9]+\\)$" line) + (if (string-match "\\([[:digit:]]+\\)$" line) (let ((length (- (max 10 (1+ (length (match-string 1 line))))))) (setq size (string-to-number (match-string 1 line))) (when (string-match @@ -1844,7 +1881,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." (if (and (process-live-p (tramp-get-connection-process vec)) (tramp-get-connection-property vec "posix" t)) (with-tramp-connection-property - (tramp-get-connection-process vec) "cifs-capabilities" + (tramp-get-process vec) "cifs-capabilities" (save-match-data (when (tramp-smb-send-command vec "posix") (with-current-buffer (tramp-get-connection-buffer vec) @@ -1861,8 +1898,7 @@ are listed. Result is the list (LOCALNAME MODE SIZE MTIME)." ;; When we are not logged in yet, we return nil. (if (and (tramp-smb-get-share vec) (process-live-p (tramp-get-connection-process vec))) - (with-tramp-connection-property - (tramp-get-connection-process vec) "stat-capability" + (with-tramp-connection-property (tramp-get-process vec) "stat-capability" (tramp-smb-send-command vec "stat \"/\"")))) @@ -1924,11 +1960,9 @@ If ARGUMENT is non-nil, use it as argument for ;; connection timeout. (with-current-buffer buf (goto-char (point-min)) - ;; `seconds-to-time' can be removed once we get rid of Emacs 24. - (when (and (time-less-p (seconds-to-time 60) - (time-since - (tramp-get-connection-property - p "last-cmd-time" (seconds-to-time 0)))) + (when (and (time-less-p + 60 (time-since + (tramp-get-connection-property p "last-cmd-time" 0))) (process-live-p p) (re-search-forward tramp-smb-errors nil t)) (delete-process p) @@ -1949,6 +1983,7 @@ If ARGUMENT is non-nil, use it as argument for (host (tramp-file-name-host vec)) (domain (tramp-file-name-domain vec)) (port (tramp-file-name-port vec)) + (options tramp-smb-options) args) (cond @@ -1967,6 +2002,10 @@ If ARGUMENT is non-nil, use it as argument for (when port (setq args (append args (list "-p" port)))) (when tramp-smb-conf (setq args (append args (list "-s" tramp-smb-conf)))) + (while options + (setq args + (append args `("--option" ,(format "%s" (car options)))) + options (cdr options))) (when argument (setq args (append args (list argument)))) @@ -1994,7 +2033,7 @@ If ARGUMENT is non-nil, use it as argument for (set-process-query-on-exit-flag p nil) (condition-case err - (let (tramp-message-show-message) + (let ((inhibit-message t)) ;; Play login scenario. (tramp-process-actions p vec nil @@ -2132,7 +2171,5 @@ Removes smb prompt. Returns nil if an error message has appeared." ;; ;; * Try to remove the inclusion of dummy "" directory. Seems to be at ;; several places, especially in `tramp-smb-handle-insert-directory'. -;; -;; * Ignore case in file names. ;;; tramp-smb.el ends here diff --git a/lisp/net/tramp-sudoedit.el b/lisp/net/tramp-sudoedit.el index 08188cefde3..98727dc4a87 100644 --- a/lisp/net/tramp-sudoedit.el +++ b/lisp/net/tramp-sudoedit.el @@ -132,6 +132,8 @@ See `tramp-actions-before-shell' for more info.") (start-file-process . ignore) (substitute-in-file-name . tramp-handle-substitute-in-file-name) (temporary-file-directory . tramp-handle-temporary-file-directory) + (tramp-get-remote-gid . tramp-sudoedit-handle-get-remote-gid) + (tramp-get-remote-uid . tramp-sudoedit-handle-get-remote-uid) (tramp-set-file-uid-gid . tramp-sudoedit-handle-set-file-uid-gid) (unhandled-file-name-directory . ignore) (vc-registered . ignore) @@ -153,10 +155,9 @@ See `tramp-actions-before-shell' for more info.") "Invoke the SUDOEDIT handler for OPERATION and ARGS. First arg specifies the OPERATION, second arg is a list of arguments to pass to the OPERATION." - (let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) - (if fn - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let ((fn (assoc operation tramp-sudoedit-file-name-handler-alist))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###tramp-autoload (tramp--with-startup @@ -248,7 +249,7 @@ absolute file names." (when (and (not ok-if-already-exists) (file-exists-p newname)) (tramp-error v 'file-already-exists newname)) (when (and (file-directory-p newname) - (not (tramp-compat-directory-name-p newname))) + (not (directory-name-p newname))) (tramp-error v 'file-error "File is a directory %s" newname)) (if (or (and (file-remote-p filename) (not t1)) @@ -265,10 +266,8 @@ absolute file names." v 0 (format "%s %s to %s" msg-operation filename newname) (unless (tramp-sudoedit-send-command v sudoedit-operation - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename)) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name newname))) + (tramp-unquote-file-local-name filename) + (tramp-unquote-file-local-name newname)) (tramp-error v 'file-error "Error %s `%s' `%s'" msg-operation filename newname)))) @@ -284,7 +283,8 @@ absolute file names." ;; Set the time and mode. Mask possible errors. (when keep-date (ignore-errors - (set-file-times newname file-times) + (tramp-compat-set-file-times + newname file-times (unless ok-if-already-exists 'nofollow)) (set-file-modes newname file-modes))) ;; Handle `preserve-extended-attributes'. We ignore possible @@ -305,8 +305,8 @@ absolute file names." (filename newname &optional ok-if-already-exists keep-date preserve-uid-gid preserve-extended-attributes) "Like `copy-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -375,7 +375,7 @@ the result will be a local, non-Tramp, file name." (defun tramp-sudoedit-remote-acl-p (vec) "Check, whether ACL is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "acl-p" + (with-tramp-connection-property (tramp-get-process vec) "acl-p" (zerop (tramp-call-process vec "getfacl" nil nil nil "/")))) (defun tramp-sudoedit-handle-file-acl (filename) @@ -466,19 +466,21 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "test" "-r" (tramp-compat-file-name-unquote localname))))) -(defun tramp-sudoedit-handle-set-file-modes (filename mode) +(defun tramp-sudoedit-handle-set-file-modes (filename mode &optional flag) "Like `set-file-modes' for Tramp files." (with-parsed-tramp-file-name filename nil - (tramp-flush-file-properties v localname) - (unless (tramp-sudoedit-send-command - v "chmod" (format "%o" mode) - (tramp-compat-file-name-unquote localname)) - (tramp-error - v 'file-error "Error while changing file's mode %s" filename)))) + ;; It is unlikely that "chmod -h" works. + (unless (and (eq flag 'nofollow) (file-symlink-p filename)) + (tramp-flush-file-properties v localname) + (unless (tramp-sudoedit-send-command + v "chmod" (format "%o" mode) + (tramp-compat-file-name-unquote localname)) + (tramp-error + v 'file-error "Error while changing file's mode %s" filename))))) (defun tramp-sudoedit-remote-selinux-p (vec) "Check, whether SELINUX is enabled on the remote host." - (with-tramp-connection-property (tramp-get-connection-process vec) "selinux-p" + (with-tramp-connection-property (tramp-get-process vec) "selinux-p" (zerop (tramp-call-process vec "selinuxenabled")))) (defun tramp-sudoedit-handle-file-selinux-context (filename) @@ -486,9 +488,8 @@ the result will be a local, non-Tramp, file name." (with-parsed-tramp-file-name filename nil (with-tramp-file-property v localname "file-selinux-context" (let ((context '(nil nil nil nil)) - (regexp (eval-when-compile - (concat "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\):" - "\\([a-z0-9_]+\\):" "\\([a-z0-9_]+\\)")))) + (regexp (concat "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\):" + "\\([[:alnum:]_]+\\):" "\\([[:alnum:]_]+\\)"))) (when (and (tramp-sudoedit-remote-selinux-p v) (tramp-sudoedit-send-command v "ls" "-d" "-Z" @@ -513,10 +514,9 @@ the result will be a local, non-Tramp, file name." (goto-char (point-min)) (forward-line) (when (looking-at - (eval-when-compile - (concat "[[:space:]]*\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)" - "[[:space:]]+\\([[:digit:]]+\\)"))) + (concat "[[:space:]]*\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)" + "[[:space:]]+\\([[:digit:]]+\\)")) (list (string-to-number (match-string 1)) ;; The second value is the used size. We need the ;; free size. @@ -524,7 +524,7 @@ the result will be a local, non-Tramp, file name." (string-to-number (match-string 2))) (string-to-number (match-string 3))))))))) -(defun tramp-sudoedit-handle-set-file-times (filename &optional time) +(defun tramp-sudoedit-handle-set-file-times (filename &optional time flag) "Like `set-file-times' for Tramp files." (with-parsed-tramp-file-name filename nil (tramp-flush-file-properties v localname) @@ -537,14 +537,14 @@ the result will be a local, non-Tramp, file name." (tramp-sudoedit-send-command v "env" "TZ=UTC" "touch" "-t" (format-time-string "%Y%m%d%H%M.%S" time t) + (if (eq flag 'nofollow) "-h" "") (tramp-compat-file-name-unquote localname))))) (defun tramp-sudoedit-handle-file-truename (filename) "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -615,9 +615,7 @@ component is used as the target of the symlink." (let ((non-essential t)) (when (and (tramp-tramp-file-p target) (tramp-file-name-equal-p v (tramp-dissect-file-name target))) - (setq target - (tramp-file-name-localname - (tramp-dissect-file-name (expand-file-name target)))))) + (setq target (tramp-file-local-name (expand-file-name target))))) ;; If TARGET is still remote, quote it. (if (tramp-tramp-file-p target) @@ -646,8 +644,8 @@ component is used as the target of the symlink." (defun tramp-sudoedit-handle-rename-file (filename newname &optional ok-if-already-exists) "Like `rename-file' for Tramp files." - (setq filename (expand-file-name filename)) - (setq newname (expand-file-name newname)) + (setq filename (expand-file-name filename) + newname (expand-file-name newname)) ;; At least one file a Tramp file? (if (or (tramp-tramp-file-p filename) (tramp-tramp-file-p newname)) @@ -691,21 +689,19 @@ component is used as the target of the symlink." (tramp-flush-file-property v localname "file-selinux-context")) t))))) -(defun tramp-sudoedit-get-remote-uid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-uid (vec id-format) "The uid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "uid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-u") - (tramp-sudoedit-send-command-string vec "id" "-un")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-u") + (tramp-sudoedit-send-command-string vec "id" "-un"))) -(defun tramp-sudoedit-get-remote-gid (vec id-format) +(defun tramp-sudoedit-handle-get-remote-gid (vec id-format) "The gid of the remote connection VEC, in ID-FORMAT. ID-FORMAT valid values are `string' and `integer'." - (with-tramp-connection-property vec (format "gid-%s" id-format) - (if (equal id-format 'integer) - (tramp-sudoedit-send-command-and-read vec "id" "-g") - (tramp-sudoedit-send-command-string vec "id" "-gn")))) + (if (equal id-format 'integer) + (tramp-sudoedit-send-command-and-read vec "id" "-g") + (tramp-sudoedit-send-command-string vec "id" "-gn"))) (defun tramp-sudoedit-handle-set-file-uid-gid (filename &optional uid gid) "Like `tramp-set-file-uid-gid' for Tramp files." @@ -713,22 +709,22 @@ ID-FORMAT valid values are `string' and `integer'." (tramp-sudoedit-send-command v "chown" (format "%d:%d" - (or uid (tramp-sudoedit-get-remote-uid v 'integer)) - (or gid (tramp-sudoedit-get-remote-gid v 'integer))) - (tramp-compat-file-name-unquote - (tramp-compat-file-local-name filename))))) + (or uid (tramp-get-remote-uid v 'integer)) + (or gid (tramp-get-remote-gid v 'integer))) + (tramp-unquote-file-local-name filename)))) (defun tramp-sudoedit-handle-write-region (start end filename &optional append visit lockname mustbenew) "Like `write-region' for Tramp files." (with-parsed-tramp-file-name filename nil - (let ((uid (or (tramp-compat-file-attribute-user-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-uid v 'integer))) - (gid (or (tramp-compat-file-attribute-group-id - (file-attributes filename 'integer)) - (tramp-sudoedit-get-remote-gid v 'integer))) - (modes (tramp-default-file-modes filename))) + (let* ((uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer))) + (flag (and (eq mustbenew 'excl) 'nofollow)) + (modes (tramp-default-file-modes filename flag))) (prog1 (tramp-handle-write-region start end filename append visit lockname mustbenew) @@ -742,7 +738,7 @@ ID-FORMAT valid values are `string' and `integer'." (file-attributes filename 'integer)) gid)) (tramp-set-file-uid-gid filename uid gid)) - (set-file-modes filename modes))))) + (tramp-compat-set-file-modes filename modes flag))))) ;; Internal functions. @@ -787,14 +783,7 @@ connection if a previous connection has died for some reason." (tramp-set-connection-local-variables vec) ;; Mark it as connected. - (tramp-set-connection-property p "connected" t)) - - ;; In `tramp-check-cached-permissions', the connection properties - ;; "{uid,gid}-{integer,string}" are used. We set them to proper values. - (tramp-sudoedit-get-remote-uid vec 'integer) - (tramp-sudoedit-get-remote-gid vec 'integer) - (tramp-sudoedit-get-remote-uid vec 'string) - (tramp-sudoedit-get-remote-gid vec 'string))) + (tramp-set-connection-property p "connected" t)))) (defun tramp-sudoedit-send-command (vec &rest args) "Send commands ARGS to connection VEC. diff --git a/lisp/net/tramp-uu.el b/lisp/net/tramp-uu.el index 6a044e58840..f368f72a8dc 100644 --- a/lisp/net/tramp-uu.el +++ b/lisp/net/tramp-uu.el @@ -94,8 +94,3 @@ (provide 'tramp-uu) ;;; tramp-uu.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/tramp.el b/lisp/net/tramp.el index 4f3249d966a..19cf3334502 100644 --- a/lisp/net/tramp.el +++ b/lisp/net/tramp.el @@ -7,8 +7,8 @@ ;; Maintainer: Michael Albinus <michael.albinus@gmx.de> ;; Keywords: comm, processes ;; Package: tramp -;; Version: 2.4.3 -;; Package-Requires: ((emacs "24.4")) +;; Version: 2.5.0-pre +;; Package-Requires: ((emacs "25.1")) ;; Package-Type: multi ;; URL: https://savannah.gnu.org/projects/tramp @@ -37,7 +37,7 @@ ;; For more detailed instructions, please see the info file. ;; ;; Notes: -;; ----- +;; ------ ;; ;; Also see the todo list at the bottom of this file. ;; @@ -46,6 +46,7 @@ ;; ;; There's a mailing list for this, as well. Its name is: ;; tramp-devel@gnu.org + ;; You can use the Web to subscribe, under the following URL: ;; https://lists.gnu.org/mailman/listinfo/tramp-devel ;; @@ -63,6 +64,7 @@ ;; Pacify byte-compiler. (require 'cl-lib) +(declare-function file-notify-rm-watch "filenotify") (declare-function netrc-parse "netrc") (defvar auto-save-file-name-transforms) @@ -558,7 +560,7 @@ Sometimes the prompt is reported to look like \"login as:\"." ;; Allow also [] style prompts. They can appear only during ;; connection initialization; Tramp redefines the prompt afterwards. (concat "\\(?:^\\|\r\\)" - "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[0-9;]*[a-zA-Z] *\\)*") + "[^]#$%>\n]*#?[]#$%>] *\\(\e\\[[[:digit:];]*[[:alpha:]] *\\)*") "Regexp to match prompts from remote shell. Normally, Tramp expects you to configure `shell-prompt-pattern' correctly, but sometimes it happens that you are connecting to a @@ -599,7 +601,7 @@ The `sudo' program appears to insert a `^@' character into the prompt." "\\|" "^.*\\(" ;; Here comes a list of regexes, separated by \\| - "Received signal [0-9]+" + "Received signal [[:digit:]]+" "\\).*") "Regexp matching a `login failed' message. The regexp should match at end of buffer." @@ -744,7 +746,7 @@ to be set, depending on VALUE." tramp-postfix-host-format (tramp-build-postfix-host-format) tramp-postfix-host-regexp (tramp-build-postfix-host-regexp) tramp-remote-file-name-spec-regexp - (tramp-build-remote-file-name-spec-regexp) + (tramp-build-remote-file-name-spec-regexp) tramp-file-name-structure (tramp-build-file-name-structure) tramp-file-name-regexp (tramp-build-file-name-regexp) tramp-completion-file-name-regexp @@ -795,9 +797,9 @@ Used in `tramp-make-tramp-file-name'.") Should always start with \"^\". Derived from `tramp-prefix-format'.") (defconst tramp-method-regexp-alist - '((default . "[a-zA-Z0-9-]+") + '((default . "[[:alnum:]-]+") (simplified . "") - (separate . "[a-zA-Z0-9-]*")) + (separate . "[[:alnum:]-]*")) "Alist mapping Tramp syntax to regexps matching methods identifiers.") (defun tramp-build-method-regexp () @@ -841,7 +843,7 @@ Derived from `tramp-postfix-method-format'.") "Regexp matching delimiter between user and domain names. Derived from `tramp-prefix-domain-format'.") -(defconst tramp-domain-regexp "[a-zA-Z0-9_.-]+" +(defconst tramp-domain-regexp "[[:alnum:]_.-]+" "Regexp matching domain names.") (defconst tramp-user-with-domain-regexp @@ -858,7 +860,7 @@ Used in `tramp-make-tramp-file-name'.") "Regexp matching delimiter between user and host names. Derived from `tramp-postfix-user-format'.") -(defconst tramp-host-regexp "[a-zA-Z0-9_.%-]+" +(defconst tramp-host-regexp "[[:alnum:]_.%-]+" "Regexp matching host names.") (defconst tramp-prefix-ipv6-format-alist @@ -886,7 +888,7 @@ Derived from `tramp-prefix-ipv6-format'.") ;; The following regexp is a bit sloppy. But it shall serve our ;; purposes. It covers also IPv4 mapped IPv6 addresses, like in ;; "::ffff:192.168.0.1". -(defconst tramp-ipv6-regexp "\\(?:[a-zA-Z0-9]*:\\)+[a-zA-Z0-9.]+" +(defconst tramp-ipv6-regexp "\\(?:[[:alnum:]]*:\\)+[[:alnum:].]+" "Regexp matching IPv6 addresses.") (defconst tramp-postfix-ipv6-format-alist @@ -918,7 +920,7 @@ Derived from `tramp-postfix-ipv6-format'.") "Regexp matching delimiter between host names and port numbers. Derived from `tramp-prefix-port-format'.") -(defconst tramp-port-regexp "[0-9]+" +(defconst tramp-port-regexp "[[:digit:]]+" "Regexp matching port numbers.") (defconst tramp-host-with-port-regexp @@ -1258,7 +1260,7 @@ calling HANDLER.") ;; data structure. ;; The basic structure for remote file names. We use a list :type, -;; in order to be compatible with Emacs 24 and 25. +;; in order to be compatible with Emacs 25. (cl-defstruct (tramp-file-name (:type list) :named) method user domain host port localname hop) @@ -1306,9 +1308,10 @@ entry does not exist, return nil." ;; We use the cached property. (tramp-get-connection-property vec hash-entry nil) ;; Use the static value from `tramp-methods'. - (let ((methods-entry - (assoc param (assoc (tramp-file-name-method vec) tramp-methods)))) - (when methods-entry (cadr methods-entry)))))) + (when-let ((methods-entry + (assoc + param (assoc (tramp-file-name-method vec) tramp-methods)))) + (cadr methods-entry))))) ;; The localname can be quoted with "/:". Extract this. (defun tramp-file-name-unquote-localname (vec) @@ -1347,6 +1350,11 @@ of `process-file', `start-file-process', or `shell-command'." (match-string (nth 4 tramp-file-name-structure) name)) (tramp-compat-file-local-name name))) +;; The localname can be quoted with "/:". Extract this. +(defun tramp-unquote-file-local-name (name) + "Return unquoted localname of NAME." + (tramp-compat-file-name-unquote (tramp-file-local-name name))) + (defun tramp-find-method (method user host) "Return the right method string to use depending on USER and HOST. This is METHOD, if non-nil. Otherwise, do a lookup in @@ -1363,8 +1371,8 @@ This is METHOD, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or host "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lmethod (nth 2 item)) - (setq choices nil))) + (setq lmethod (nth 2 item) + choices nil))) lmethod) tramp-default-method))) ;; We must mark, whether a default value has been used. @@ -1384,8 +1392,8 @@ This is USER, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or host ""))) - (setq luser (nth 2 item)) - (setq choices nil))) + (setq luser (nth 2 item) + choices nil))) luser) tramp-default-user))) ;; We must mark, whether a default value has been used. @@ -1405,8 +1413,8 @@ This is HOST, if non-nil. Otherwise, do a lookup in (setq item (pop choices)) (when (and (string-match-p (or (nth 0 item) "") (or method "")) (string-match-p (or (nth 1 item) "") (or user ""))) - (setq lhost (nth 2 item)) - (setq choices nil))) + (setq lhost (nth 2 item) + choices nil))) lhost) tramp-default-host))) ;; We must mark, whether a default value has been used. @@ -1468,7 +1476,7 @@ default values are used." :method method :user user :domain domain :host host :port port :localname localname :hop hop)) ;; The method must be known. - (unless (or nodefault (tramp-completion-mode-p) + (unless (or nodefault non-essential (string-equal method tramp-default-method-marker) (assoc method tramp-methods)) (tramp-user-error @@ -1592,7 +1600,7 @@ necessary only. This function will be used in file name completion." tramp-prefix-ipv6-format host tramp-postfix-ipv6-format) host) tramp-postfix-host-format)) - (when localname localname))) + localname)) (defun tramp-get-buffer (vec &optional dont-create) "Get the connection buffer to be used for VEC. @@ -1625,6 +1633,15 @@ from the default one." (or (tramp-get-connection-property vec "process-name" nil) (tramp-buffer-name vec))) +(defun tramp-get-process (vec-or-proc) + "Get the default connection process to be used for VEC-OR-PROC. +Return `tramp-cache-undefined' in case it doesn't exist." + (or (and (tramp-file-name-p vec-or-proc) + (get-buffer-process (tramp-buffer-name vec-or-proc))) + (and (processp vec-or-proc) + (tramp-get-process (process-get vec-or-proc 'vector))) + tramp-cache-undefined)) + (defun tramp-get-connection-process (vec) "Get the connection process to be used for VEC. In case a second asynchronous communication has been started, it is different @@ -1648,7 +1665,7 @@ version, the function does nothing." "Set connection-local variables in the current buffer. If connection-local variables are not supported by this Emacs version, the function does nothing." - (when (file-remote-p default-directory) + (when (tramp-tramp-file-p default-directory) ;; `hack-connection-local-variables-apply' exists since Emacs 26.1. (tramp-compat-funcall 'hack-connection-local-variables-apply @@ -1667,11 +1684,10 @@ version, the function does nothing." (format "*debug tramp/%s %s*" method host-port)))) (defconst tramp-debug-outline-regexp - (eval-when-compile - (concat - "[0-9]+:[0-9]+:[0-9]+\\.[0-9]+ " ;; Timestamp. - "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. - "[a-z0-9-]+ (\\([0-9]+\\)) #")) ;; Function name, verbosity. + (concat + "[[:digit:]]+:[[:digit:]]+:[[:digit:]]+\\.[[:digit:]]+ " ;; Timestamp. + "\\(?:\\(#<thread .+>\\) \\)?" ;; Thread. + "[[:alnum:]-]+ (\\([[:digit:]]+\\)) #") ;; Function name, verbosity. "Used for highlighting Tramp debug buffers in `outline-mode'.") (defconst tramp-debug-font-lock-keywords @@ -1744,29 +1760,10 @@ ARGUMENTS to actually emit the message (if applicable)." (setq btf (nth 1 (backtrace-frame btn))) (if (not btf) (setq fn "") - (when (symbolp btf) - (setq fn (symbol-name btf)) - (unless - (and - (string-match-p "^tramp" fn) - (not - (string-match-p - (eval-when-compile - (concat - "^" - (regexp-opt - '("tramp-backtrace" - "tramp-compat-funcall" - "tramp-debug-message" - "tramp-error" - "tramp-error-with-buffer" - "tramp-message" - "tramp-signal-hook-function" - "tramp-user-error") - t) - "$")) - fn))) - (setq fn nil))) + (and (symbolp btf) (setq fn (symbol-name btf)) + (or (not (string-match-p "^tramp" fn)) + (get btf 'tramp-suppress-trace)) + (setq fn nil)) (setq btn (1+ btn)))) ;; The following code inserts filename and line number. Should ;; be inactive by default, because it is time consuming. @@ -1781,11 +1778,11 @@ ARGUMENTS to actually emit the message (if applicable)." ;; The message. (insert (apply #'format-message fmt-string arguments)))) -(defvar tramp-message-show-message (null noninteractive) - "Show Tramp message in the minibuffer. -This variable is used to suppress progress reporter output, and -to disable messages from `tramp-error'. Those messages are -visible anyway, because an error is raised.") +(put #'tramp-debug-message 'tramp-suppress-trace t) + +(defvar tramp-inhibit-progress-reporter nil + "Show Tramp progress reporter in the minibuffer. +This variable is used to disable concurrent progress reporter messages.") (defsubst tramp-message (vec-or-proc level fmt-string &rest arguments) "Emit a message depending on verbosity level. @@ -1802,8 +1799,9 @@ control string and the remaining ARGUMENTS to actually emit the message (if applicable)." (ignore-errors (when (<= level tramp-verbose) - ;; Display only when there is a minimum level. - (when (and tramp-message-show-message (<= level 3)) + ;; Display only when there is a minimum level, and the progress + ;; reporter doesn't suppress further messages. + (when (and (<= level 3) (null tramp-inhibit-progress-reporter)) (apply #'message (concat (cond @@ -1835,6 +1833,8 @@ applicable)." (concat (format "(%d) # " level) fmt-string) arguments)))))) +(put #'tramp-message 'tramp-suppress-trace t) + (defsubst tramp-backtrace (&optional vec-or-proc) "Dump a backtrace into the debug buffer. If VEC-OR-PROC is nil, the buffer *debug tramp* is used. This @@ -1845,13 +1845,16 @@ function is meant for debugging purposes." vec-or-proc 10 "\n%s" (with-output-to-string (backtrace))) (with-output-to-temp-buffer "*debug tramp*" (backtrace))))) +(put #'tramp-backtrace 'tramp-suppress-trace t) + (defsubst tramp-error (vec-or-proc signal fmt-string &rest arguments) "Emit an error. VEC-OR-PROC identifies the connection to use, SIGNAL is the signal identifier to be raised, remaining arguments passed to `tramp-message'. Finally, signal SIGNAL is raised with FMT-STRING and ARGUMENTS." - (let (tramp-message-show-message signal-hook-function) + (let ((inhibit-message t) + signal-hook-function) (tramp-backtrace vec-or-proc) (unless arguments ;; FMT-STRING could be just a file name, as in @@ -1869,6 +1872,8 @@ FMT-STRING and ARGUMENTS." (signal signal (list (substring-no-properties (apply #'format-message fmt-string arguments)))))) +(put #'tramp-error 'tramp-suppress-trace t) + (defsubst tramp-error-with-buffer (buf vec-or-proc signal fmt-string &rest arguments) "Emit an error, and show BUF. @@ -1886,13 +1891,13 @@ an input event arrives. The other arguments are passed to `tramp-error'." (apply #'tramp-error vec-or-proc signal fmt-string arguments) ;; Save exit. (when (and buf - tramp-message-show-message (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ;; ourselves. (apply #'message fmt-string arguments) @@ -1904,19 +1909,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (when (tramp-file-name-equal-p vec (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-error-with-buffer 'tramp-suppress-trace t) + ;; We must make it a defun, because it is used earlier already. (defun tramp-user-error (vec-or-proc fmt-string &rest arguments) "Signal a user error (or \"pilot error\")." (unwind-protect (apply #'tramp-error vec-or-proc 'user-error fmt-string arguments) ;; Save exit. - (when (and tramp-message-show-message - (not (zerop tramp-verbose)) + (when (and (not (zerop tramp-verbose)) ;; Do not show when flagged from outside. - (not (tramp-completion-mode-p)) + (not non-essential) ;; Show only when Emacs has started already. (current-message)) - (let ((enable-recursive-minibuffers t)) + (let ((enable-recursive-minibuffers t) + inhibit-message) ;; `tramp-error' does not show messages. So we must do it ourselves. (apply #'message fmt-string arguments) (discard-input) @@ -1926,18 +1933,21 @@ an input event arrives. The other arguments are passed to `tramp-error'." (tramp-file-name-equal-p vec-or-proc (car tramp-current-connection)) (setcdr tramp-current-connection (current-time))))))) +(put #'tramp-user-error 'tramp-suppress-trace t) + (defmacro tramp-with-demoted-errors (vec-or-proc format &rest body) "Execute BODY while redirecting the error message to `tramp-message'. BODY is executed like wrapped by `with-demoted-errors'. FORMAT is a format-string containing a %-sequence meaning to substitute the resulting error message." - (declare (debug (symbolp body)) - (indent 2)) + (declare (indent 2) (debug (symbolp form body))) (let ((err (make-symbol "err"))) `(condition-case-unless-debug ,err (progn ,@body) (error (tramp-message ,vec-or-proc 3 ,format ,err) nil)))) +(put #'tramp-with-demoted-errors 'tramp-suppress-trace t) + ;; This function provides traces in case of errors not triggered by ;; Tramp functions. (defun tramp-signal-hook-function (error-symbol data) @@ -1949,6 +1959,8 @@ the resulting error message." (car tramp-current-connection) error-symbol "%s" (mapconcat (lambda (x) (format "%s" x)) data " ")))) +(put #'tramp-signal-hook-function 'tramp-suppress-trace t) + (defmacro with-parsed-tramp-file-name (filename var &rest body) "Parse a Tramp filename and make components available in the body. @@ -1965,12 +1977,14 @@ Remaining args are Lisp expressions to be evaluated (inside an implicit If VAR is nil, then we bind `v' to the structure and `method', `user', `domain', `host', `port', `localname', `hop' to the components." + (declare (indent 2) (debug (form symbolp body))) (let ((bindings - (mapcar (lambda (elem) - `(,(if var (intern (format "%s-%s" var elem)) elem) - (,(intern (format "tramp-file-name-%s" elem)) - ,(or var 'v)))) - `,(tramp-compat-tramp-file-name-slots)))) + (mapcar + (lambda (elem) + `(,(if var (intern (format "%s-%s" var elem)) elem) + (,(intern (format "tramp-file-name-%s" elem)) + ,(or var 'v)))) + (cdr (mapcar #'car (cl-struct-slot-info 'tramp-file-name)))))) `(let* ((,(or var 'v) (tramp-dissect-file-name ,filename)) ,@bindings) ;; We don't know which of those vars will be used, so we bind them all, @@ -1979,8 +1993,6 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (ignore ,@(mapcar #'car bindings)) ,@body))) -(put 'with-parsed-tramp-file-name 'lisp-indent-function 2) -(put 'with-parsed-tramp-file-name 'edebug-form-spec '(form symbolp body)) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-parsed-tramp-file-name\\>")) (defun tramp-progress-reporter-update (reporter &optional value suffix) @@ -1991,25 +2003,30 @@ If VAR is nil, then we bind `v' to the structure and `method', `user', (tramp-compat-progress-reporter-update reporter value suffix)))) (defmacro with-tramp-progress-reporter (vec level message &rest body) - "Execute BODY, spinning a progress reporter with MESSAGE. + "Execute BODY, spinning a progress reporter with MESSAGE in interactive mode. If LEVEL does not fit for visible messages, there are only traces without a visible progress reporter." (declare (indent 3) (debug t)) - `(progn + `(if (or noninteractive inhibit-message) + (progn ,@body) (tramp-message ,vec ,level "%s..." ,message) (let ((cookie "failed") (tm ;; We start a pulsing progress reporter after 3 seconds. - (when (and tramp-message-show-message - ;; Display only when there is a minimum level. - (<= ,level (min tramp-verbose 3))) - (let ((pr (make-progress-reporter ,message nil nil))) - (when pr - (run-at-time - 3 0.1 #'tramp-progress-reporter-update pr)))))) + ;; Start only when there is no other progress reporter + ;; running, and when there is a minimum level. + (when-let ((pr (and (null tramp-inhibit-progress-reporter) + (<= ,level (min tramp-verbose 3)) + (make-progress-reporter ,message nil nil)))) + (run-at-time 3 0.1 #'tramp-progress-reporter-update pr)))) (unwind-protect ;; Execute the body. - (prog1 (progn ,@body) (setq cookie "done")) + (prog1 + ;; Suppress concurrent progress reporter messages. + (let ((tramp-inhibit-progress-reporter + (or tramp-inhibit-progress-reporter tm))) + ,@body) + (setq cookie "done")) ;; Stop progress reporter. (if tm (cancel-timer tm)) (tramp-message ,vec ,level "%s...%s" ,message cookie))))) @@ -2020,6 +2037,7 @@ without a visible progress reporter." (defmacro with-tramp-file-property (vec file property &rest body) "Check in Tramp cache for PROPERTY, otherwise execute BODY and set cache. FILE must be a local file name on a connection identified via VEC." + (declare (indent 3) (debug t)) `(if (file-name-absolute-p ,file) (let ((value (tramp-get-file-property ,vec ,file ,property 'undef))) (when (eq value 'undef) @@ -2031,12 +2049,11 @@ FILE must be a local file name on a connection identified via VEC." value) ,@body)) -(put 'with-tramp-file-property 'lisp-indent-function 3) -(put 'with-tramp-file-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-file-property\\>")) (defmacro with-tramp-connection-property (key property &rest body) "Check in Tramp for property PROPERTY, otherwise execute BODY and set." + (declare (indent 2) (debug t)) `(let ((value (tramp-get-connection-property ,key ,property 'undef))) (when (eq value 'undef) ;; We cannot pass ,@body as parameter to @@ -2046,8 +2063,6 @@ FILE must be a local file name on a connection identified via VEC." (tramp-set-connection-property ,key ,property value)) value)) -(put 'with-tramp-connection-property 'lisp-indent-function 2) -(put 'with-tramp-connection-property 'edebug-form-spec t) (font-lock-add-keywords 'emacs-lisp-mode '("\\<with-tramp-connection-property\\>")) @@ -2060,12 +2075,15 @@ letter into the file name. This function removes it." (save-match-data (let ((quoted (tramp-compat-file-name-quoted-p name 'top)) (result (tramp-compat-file-name-unquote name 'top))) - (setq result (if (string-match "\\`[a-zA-Z]:/" result) + (setq result (if (string-match "\\`[[:alpha:]]:/" result) (replace-match "/" nil t result) result)) (if quoted (tramp-compat-file-name-quote result 'top) result)))) ;;; Config Manipulation Functions: +(defconst tramp-dns-sd-service-regexp "^_[-[:alnum:]]+\\._tcp$" + "DNS-SD service regexp.") + (defun tramp-set-completion-function (method function-list) "Set the list of completion functions for METHOD. FUNCTION-LIST is a list of entries of the form (FUNCTION FILE). @@ -2098,10 +2116,10 @@ Example: (zerop (tramp-call-process v "reg" nil nil nil "query" (nth 1 (car v)))))) - ;; Zeroconf service type. + ;; DNS-SD service type. ((string-match-p - "^_[[:alpha:]]+\\._[[:alpha:]]+$" (nth 1 (car v)))) - ;; Configuration file. + tramp-dns-sd-service-regexp (nth 1 (car v)))) + ;; Configuration file or empty string. (t (file-exists-p (nth 1 (car v)))))) (setq r (delete (car v) r))) (setq v (cdr v))) @@ -2139,11 +2157,13 @@ For definition of that list see `tramp-set-completion-function'." (defvar tramp-devices 0 "Keeps virtual device numbers.") -(defun tramp-default-file-modes (filename) +(defun tramp-default-file-modes (filename &optional flag) "Return file modes of FILENAME as integer. -If the file modes of FILENAME cannot be determined, return the -value of `default-file-modes', without execute permissions." - (or (file-modes filename) +If optional FLAG is ‘nofollow’, do not follow FILENAME if it is a +symbolic link. If the file modes of FILENAME cannot be +determined, return the value of `default-file-modes', without +execute permissions." + (or (tramp-compat-file-modes filename flag) (logand (default-file-modes) #o0666))) (defun tramp-replace-environment-variables (filename) @@ -2174,6 +2194,7 @@ arguments to pass to the OPERATION." tramp-vc-file-name-handler tramp-completion-file-name-handler tramp-archive-file-name-handler + tramp-crypt-file-name-handler cygwin-mount-name-hook-function cygwin-mount-map-drive-hook-function . @@ -2239,7 +2260,7 @@ Must be handled by the callers." file-newer-than-file-p rename-file)) (cond ((tramp-tramp-file-p (nth 0 args)) (nth 0 args)) - ((tramp-tramp-file-p (nth 1 args)) (nth 1 args)) + ((file-name-absolute-p (nth 1 args)) (nth 1 args)) (t default-directory))) ;; FILE DIRECTORY resp FILE1 FILE2. ((eq operation 'expand-file-name) @@ -2267,13 +2288,13 @@ Must be handled by the callers." exec-path make-process)) default-directory) ;; PROC. - ((member operation - '(file-notify-rm-watch - ;; Emacs 25+ only. - file-notify-valid-p)) + ((member operation '(file-notify-rm-watch file-notify-valid-p)) (when (processp (nth 0 args)) (with-current-buffer (process-buffer (nth 0 args)) default-directory))) + ;; VEC. + ((member operation '(tramp-get-remote-gid tramp-get-remote-uid)) + (tramp-make-tramp-file-name (nth 0 args))) ;; Unknown file primitive. (t (error "Unknown file I/O primitive: %s" operation)))) @@ -2390,7 +2411,7 @@ Fall back to normal file name handler if no Tramp file name handler exists." (cons operation args)) (tramp-run-real-handler operation args)) ((eq result 'suppress) - (let (tramp-message-show-message) + (let ((inhibit-message t)) (tramp-message v 1 "Suppress received in operation %s" (cons operation args)) @@ -2419,18 +2440,21 @@ Fall back to normal file name handler if no Tramp file name handler exists." (defun tramp-completion-file-name-handler (operation &rest args) "Invoke Tramp file name completion handler for OPERATION and ARGS. Falls back to normal file name handler if no Tramp file name handler exists." - (let ((fn (assoc operation tramp-completion-file-name-handler-alist))) - (if (and fn tramp-mode) - (save-match-data (apply (cdr fn) args)) - (tramp-run-real-handler operation args)))) + (if-let + ((fn (and tramp-mode + (assoc operation tramp-completion-file-name-handler-alist)))) + (save-match-data (apply (cdr fn) args)) + (tramp-run-real-handler operation args))) ;;;###autoload (progn (defun tramp-autoload-file-name-handler (operation &rest args) "Load Tramp file name handler, and perform OPERATION." (tramp-unload-file-name-handlers) - (if tramp-mode - (let ((default-directory temporary-file-directory)) - (load "tramp" 'noerror 'nomessage))) + (when tramp-mode + ;; We cannot use `tramp-compat-temporary-file-directory' here due + ;; to autoload. + (let ((default-directory temporary-file-directory)) + (load "tramp" 'noerror 'nomessage))) (apply operation args))) ;; `tramp-autoload-file-name-handler' must be registered before @@ -2442,7 +2466,7 @@ Falls back to normal file name handler if no Tramp file name handler exists." (add-to-list 'file-name-handler-alist (cons tramp-autoload-file-name-regexp 'tramp-autoload-file-name-handler)) - (put 'tramp-autoload-file-name-handler 'safe-magic t))) + (put #'tramp-autoload-file-name-handler 'safe-magic t))) ;;;###autoload (tramp-register-autoload-file-name-handlers) @@ -2478,34 +2502,36 @@ remote file names." (tramp-unload-file-name-handlers) ;; Add the handlers. We do not add anything to the `operations' - ;; property of `tramp-file-name-handler' and - ;; `tramp-archive-file-name-handler', this shall be done by the + ;; property of `tramp-file-name-handler', + ;; `tramp-archive-file-name-handler' and + ;; `tramp-crypt-file-name-handler', this shall be done by the ;; respective foreign handlers. (add-to-list 'file-name-handler-alist (cons tramp-file-name-regexp #'tramp-file-name-handler)) - (put 'tramp-file-name-handler 'safe-magic t) + (put #'tramp-file-name-handler 'safe-magic t) + + (tramp-register-crypt-file-name-handler) (add-to-list 'file-name-handler-alist (cons tramp-completion-file-name-regexp #'tramp-completion-file-name-handler)) - (put 'tramp-completion-file-name-handler 'safe-magic t) + (put #'tramp-completion-file-name-handler 'safe-magic t) ;; Mark `operations' the handler is responsible for. - (put 'tramp-completion-file-name-handler 'operations + (put #'tramp-completion-file-name-handler 'operations (mapcar #'car tramp-completion-file-name-handler-alist)) (when (bound-and-true-p tramp-archive-enabled) (add-to-list 'file-name-handler-alist (cons tramp-archive-file-name-regexp #'tramp-archive-file-name-handler)) - (put 'tramp-archive-file-name-handler 'safe-magic t)) + (put #'tramp-archive-file-name-handler 'safe-magic t)) ;; If jka-compr or epa-file are already loaded, move them to the ;; front of `file-name-handler-alist'. (dolist (fnh '(epa-file-handler jka-compr-handler)) - (let ((entry (rassoc fnh file-name-handler-alist))) - (when entry - (setq file-name-handler-alist - (cons entry (delete entry file-name-handler-alist))))))) + (when-let ((entry (rassoc fnh file-name-handler-alist))) + (setq file-name-handler-alist + (cons entry (delete entry file-name-handler-alist)))))) (tramp--with-startup (tramp-register-file-name-handlers)) @@ -2517,7 +2543,7 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." (add-to-list 'tramp-foreign-file-name-handler-alist `(,func . ,handler) append) ;; Mark `operations' the handler is responsible for. - (put 'tramp-file-name-handler + (put #'tramp-file-name-handler 'operations (delete-dups (append @@ -2558,24 +2584,11 @@ Add operations defined in `HANDLER-alist' to `tramp-file-name-handler'." ;;; File name handler functions for completion mode: -;;;###autoload -(defvar tramp-completion-mode nil - "If non-nil, external packages signal that they are in file name completion.") -(make-obsolete-variable 'tramp-completion-mode 'non-essential "26.1") - -(defun tramp-completion-mode-p () - "Check, whether method / user name / host name completion is active." - (or - ;; Signal from outside. - non-essential - ;; This variable has been obsoleted in Emacs 26. - tramp-completion-mode)) - (defun tramp-connectable-p (vec-or-filename) "Check, whether it is possible to connect the remote host w/o side-effects. This is true, if either the remote host is already connected, or if we are not in completion mode." - (let (tramp-verbose + (let ((tramp-verbose 0) (vec (cond ((tramp-file-name-p vec-or-filename) vec-or-filename) @@ -2585,7 +2598,7 @@ not in completion mode." ;; `tramp-buffer-name'; otherwise `start-file-process' ;; wouldn't run ever when `non-essential' is non-nil. (and vec (process-live-p (get-process (tramp-buffer-name vec)))) - (not (tramp-completion-mode-p))))) + (not non-essential)))) ;; Method, host name and user name completion. ;; `tramp-completion-dissect-file-name' returns a list of @@ -2864,7 +2877,7 @@ User is always nil." (let ((default-directory (tramp-compat-temporary-file-directory))) (when (file-readable-p filename) (with-temp-buffer - (insert-file-contents filename) + (insert-file-contents-literally filename) (goto-char (point-min)) (cl-loop while (not (eobp)) collect (funcall function)))))) @@ -2876,7 +2889,7 @@ Either user or host may be nil." (defun tramp-parse-rhosts-group () "Return a (user host) tuple allowed to access. Either user or host may be nil." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-host-regexp "\\)" @@ -2926,7 +2939,7 @@ User is always nil." "Return a list of (user host) tuples allowed to access. User is always nil." (tramp-parse-shostkeys-sknownhosts - dirname (concat "^key_[0-9]+_\\(" tramp-host-regexp "\\)\\.pub$"))) + dirname (concat "^key_[[:digit:]]+_\\(" tramp-host-regexp "\\)\\.pub$"))) (defun tramp-parse-sknownhosts (dirname) "Return a list of (user host) tuples allowed to access. @@ -2961,7 +2974,7 @@ Host is always \"localhost\"." (defun tramp-parse-passwd-group () "Return a (user host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (regexp (concat "^\\(" tramp-user-regexp "\\):"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list (match-string 1) "localhost"))) @@ -2983,7 +2996,7 @@ Host is always \"localhost\"." (defun tramp-parse-etc-group-group () "Return a (group host) tuple allowed to access. Host is always \"localhost\"." - (let ((result) + (let (result (split (split-string (buffer-substring (point) (point-at-eol)) ":"))) (when (member (user-login-name) (split-string (nth 3 split) "," 'omit)) (setq result (list (nth 0 split) "localhost"))) @@ -3020,7 +3033,7 @@ User is always nil." (defun tramp-parse-putty-group (registry) "Return a (user host) tuple allowed to access. User is always nil." - (let ((result) + (let (result (regexp (concat (regexp-quote registry) "\\\\\\(.+\\)"))) (when (re-search-forward regexp (point-at-eol) t) (setq result (list nil (match-string 1)))) @@ -3199,12 +3212,13 @@ User is always nil." (copy-file filename tmpfile 'ok-if-already-exists 'keep-time) tmpfile))) -(defun tramp-handle-file-modes (filename) +(defun tramp-handle-file-modes (filename &optional flag) "Like `file-modes' for Tramp files." - ;; Starting with Emacs 25.1, `when-let' can be used. - (let ((attrs (file-attributes (or (file-truename filename) filename)))) - (when attrs - (tramp-mode-string-to-int (tramp-compat-file-attribute-modes attrs))))) + (when-let ((attrs (file-attributes filename)) + (mode-string (tramp-compat-file-attribute-modes attrs))) + (if (and (not (eq flag 'nofollow)) (eq ?l (aref mode-string 0))) + (file-modes (file-truename filename)) + (tramp-mode-string-to-int mode-string)))) ;; Localname manipulation functions that grok Tramp localnames... (defun tramp-handle-file-name-as-directory (file) @@ -3242,12 +3256,13 @@ User is always nil." (let ((candidate (tramp-compat-file-name-unquote (directory-file-name filename))) + case-fold-search tmpfile) ;; Check, whether we find an existing file with ;; lower case letters. This avoids us to create a ;; temporary file. (while (and (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + "[[:lower:]]" (tramp-file-local-name candidate)) (not (file-exists-p candidate))) (setq candidate (directory-file-name @@ -3256,9 +3271,8 @@ User is always nil." ;; for comparison. `make-nearby-temp-file' is added ;; to Emacs 26+ like `file-name-case-insensitive-p', ;; so there is no compatibility problem calling it. - (unless - (string-match-p - "[a-z]" (tramp-compat-file-local-name candidate)) + (unless (string-match-p + "[[:lower:]]" (tramp-file-local-name candidate)) (setq tmpfile (let ((default-directory (file-name-directory filename))) @@ -3271,7 +3285,7 @@ User is always nil." (file-exists-p (concat (file-remote-p candidate) - (upcase (tramp-compat-file-local-name candidate)))) + (upcase (tramp-file-local-name candidate)))) ;; Cleanup. (when tmpfile (delete-file tmpfile))))))))))) @@ -3323,21 +3337,18 @@ User is always nil." (cond ((not (file-exists-p file1)) nil) ((not (file-exists-p file2)) t) - (t (time-less-p (tramp-compat-file-attribute-modification-time - (file-attributes file2)) - (tramp-compat-file-attribute-modification-time - (file-attributes file1)))))) + (t (time-less-p + (tramp-compat-file-attribute-modification-time (file-attributes file2)) + (tramp-compat-file-attribute-modification-time + (file-attributes file1)))))) (defun tramp-handle-file-regular-p (filename) "Like `file-regular-p' for Tramp files." (and (file-exists-p filename) ;; Sometimes, `file-attributes' does not return a proper value ;; even if `file-exists-p' does. - (ignore-errors - (eq ?- - (aref - (tramp-compat-file-attribute-modes (file-attributes filename)) - 0))))) + (when-let ((attr (file-attributes filename))) + (eq ?- (aref (tramp-compat-file-attribute-modes attr) 0))))) (defun tramp-handle-file-remote-p (filename &optional identification connected) "Like `file-remote-p' for Tramp files." @@ -3376,8 +3387,7 @@ User is always nil." "Like `file-truename' for Tramp files." ;; Preserve trailing "/". (funcall - (if (tramp-compat-directory-name-p filename) - #'file-name-as-directory #'identity) + (if (directory-name-p filename) #'file-name-as-directory #'identity) ;; Quote properly. (funcall (if (tramp-compat-file-name-quoted-p filename) @@ -3389,6 +3399,8 @@ User is always nil." ;; something is wrong; otherwise they might think that Emacs ;; is hung. Of course, correctness has to come first. (numchase-limit 20) + ;; Unquoting could enable encryption. + tramp-crypt-enabled symlink-target) (with-parsed-tramp-file-name result v1 ;; We cache only the localname. @@ -3413,7 +3425,7 @@ User is always nil." (tramp-error v1 'file-error "Maximum number (%d) of symlinks exceeded" numchase-limit))) - (tramp-compat-file-local-name (directory-file-name result))))))))) + (tramp-file-local-name (directory-file-name result))))))))) (defun tramp-handle-file-writable-p (filename) "Like `file-writable-p' for Tramp files." @@ -3448,7 +3460,7 @@ User is always nil." "Like `insert-directory' for Tramp files." (unless switches (setq switches "")) ;; Mark trailing "/". - (when (and (tramp-compat-directory-name-p filename) + (when (and (directory-name-p filename) (not full-directory-p)) (setq switches (concat switches "F"))) ;; Check, whether directory is accessible. @@ -3458,7 +3470,7 @@ User is always nil." (with-tramp-progress-reporter v 0 (format "Opening directory %s" filename) (let (ls-lisp-use-insert-directory-program start) ;; Silence byte compiler. - ls-lisp-use-insert-directory-program + (ignore ls-lisp-use-insert-directory-program) (tramp-run-real-handler #'insert-directory (list filename switches wildcard full-directory-p)) @@ -3509,6 +3521,9 @@ User is always nil." ;; copy this part. This works only for the shell file ;; name handlers. (when (and (or beg end) + ;; Direct actions aren't possible for + ;; crypted directories. + (null tramp-crypt-enabled) (tramp-get-method-parameter v 'tramp-login-program)) (setq remote-copy (tramp-make-tramp-temp-file v)) @@ -3582,8 +3597,8 @@ User is always nil." ;; Save exit. (progn (when visit - (setq buffer-file-name filename) - (setq buffer-read-only (not (file-writable-p filename))) + (setq buffer-file-name filename + buffer-read-only (not (file-writable-p filename))) (set-visited-file-modtime) (set-buffer-modified-p nil)) (when (and (stringp local-copy) @@ -3617,7 +3632,8 @@ User is always nil." v tramp-file-missing "Cannot load nonexistent file `%s'" file)) (if (not (file-exists-p file)) nil - (let ((tramp-message-show-message (not nomessage))) + (let ((signal-hook-function (unless noerror signal-hook-function)) + (inhibit-message (or inhibit-message nomessage))) (with-tramp-progress-reporter v 0 (format "Loading %s" file) (let ((local-copy (file-local-copy file))) (unwind-protect @@ -3645,10 +3661,16 @@ support symbolic links." (let* ((asynchronous (string-match-p "[ \t]*&[ \t]*\\'" command)) (command (substring command 0 asynchronous)) current-buffer-p + (output-buffer-p output-buffer) (output-buffer (cond - ((bufferp output-buffer) output-buffer) - ((stringp output-buffer) (get-buffer-create output-buffer)) + ((bufferp output-buffer) + (setq current-buffer-p (eq (current-buffer) output-buffer)) + output-buffer) + ((stringp output-buffer) + (setq current-buffer-p + (eq (buffer-name (current-buffer)) output-buffer)) + (get-buffer-create output-buffer)) (output-buffer (setq current-buffer-p t) (current-buffer)) @@ -3660,13 +3682,19 @@ support symbolic links." (cond ((bufferp error-buffer) error-buffer) ((stringp error-buffer) (get-buffer-create error-buffer)))) + (error-file + (and error-buffer + (with-parsed-tramp-file-name default-directory nil + (tramp-make-tramp-file-name + v (tramp-make-tramp-temp-file v))))) (bname (buffer-name output-buffer)) (p (get-buffer-process output-buffer)) + (dir default-directory) buffer) ;; The following code is taken from `shell-command', slightly ;; adapted. Shouldn't it be factored out? - (when p + (when (and (integerp asynchronous) p) (cond ((eq async-shell-command-buffer 'confirm-kill-process) ;; If will kill a process, query first. @@ -3698,22 +3726,25 @@ support symbolic links." (rename-uniquely)) (setq output-buffer (get-buffer-create bname))))) - (setq buffer (if (and (not asynchronous) error-buffer) - (with-parsed-tramp-file-name default-directory nil - (list output-buffer - (tramp-make-tramp-file-name - v (tramp-make-tramp-temp-file v)))) - output-buffer)) - - (if current-buffer-p - (progn - (barf-if-buffer-read-only) - (push-mark nil t)) + (unless output-buffer-p (with-current-buffer output-buffer + (setq default-directory dir))) + + (setq buffer (if error-file (list output-buffer error-file) output-buffer)) + + (with-current-buffer output-buffer + (when current-buffer-p + (barf-if-buffer-read-only) + (push-mark nil t)) + ;; `shell-command-save-pos-or-erase' has been introduced with + ;; Emacs 27.1. + (if (fboundp 'shell-command-save-pos-or-erase) + (tramp-compat-funcall + 'shell-command-save-pos-or-erase current-buffer-p) (setq buffer-read-only nil) (erase-buffer))) - (if (and (not current-buffer-p) (integerp asynchronous)) + (if (integerp asynchronous) (let ((tramp-remote-process-environment ;; `async-shell-command-width' has been introduced with ;; Emacs 27.1. @@ -3726,42 +3757,69 @@ support symbolic links." ;; Run the process. (setq p (start-file-process-shell-command (buffer-name output-buffer) buffer command)) - ;; Display output. - (with-current-buffer output-buffer - (display-buffer output-buffer '(nil (allow-no-window . t))) - (setq mode-line-process '(":%s")) - (shell-mode) - (set-process-sentinel p #'shell-command-sentinel) - (set-process-filter p #'comint-output-filter)))) + ;; Insert error messages if they were separated. + (when error-file + (with-current-buffer error-buffer + (insert-file-contents-literally error-file))) + (if (process-live-p p) + ;; Display output. + (with-current-buffer output-buffer + (setq mode-line-process '(":%s")) + (unless (eq major-mode 'shell-mode) + (shell-mode)) + (set-process-filter p #'comint-output-filter) + (set-process-sentinel p #'shell-command-sentinel) + (when error-file + (add-function + :after (process-sentinel p) + (lambda (_proc _string) + (with-current-buffer error-buffer + (insert-file-contents-literally + error-file nil nil nil 'replace)) + (delete-file error-file)))) + (display-buffer output-buffer '(nil (allow-no-window . t)))) + + (when error-file + (delete-file error-file))))) (prog1 ;; Run the process. (process-file-shell-command command nil buffer nil) ;; Insert error messages if they were separated. - (when (listp buffer) + (when error-file (with-current-buffer error-buffer - (insert-file-contents (cadr buffer))) - (delete-file (cadr buffer))) + (insert-file-contents-literally error-file)) + (delete-file error-file)) (if current-buffer-p ;; This is like exchange-point-and-mark, but doesn't ;; activate the mark. It is cleaner to avoid activation, ;; even though the command loop would deactivate the mark ;; because we inserted text. - (goto-char (prog1 (mark t) - (set-marker (mark-marker) (point) - (current-buffer)))) + (progn + (goto-char (prog1 (mark t) + (set-marker (mark-marker) (point) + (current-buffer)))) + ;; `shell-command-set-point-after-cmd' has been + ;; introduced with Emacs 27.1. + (if (fboundp 'shell-command-set-point-after-cmd) + (tramp-compat-funcall + 'shell-command-set-point-after-cmd))) ;; There's some output, display it. (when (with-current-buffer output-buffer (> (point-max) (point-min))) (display-message-or-buffer output-buffer))))))) (defun tramp-handle-start-file-process (name buffer program &rest args) - "Like `start-file-process' for Tramp files." - ;; `make-process' knows the `:file-handler' argument since Emacs 27.1 only. + "Like `start-file-process' for Tramp files. +BUFFER might be a list, in this case STDERR is separated." + ;; `make-process' knows the `:file-handler' argument since Emacs + ;; 27.1 only. Therefore, we invoke it via `tramp-file-name-handler'. (tramp-file-name-handler 'make-process :name name - :buffer buffer + :buffer (if (consp buffer) (car buffer) buffer) :command (and program (cons program args)) + ;; `shell-command' adds an errfile to `buffer'. + :stderr (when (consp buffer) (cadr buffer)) :noquery nil :file-handler t)) @@ -3862,7 +3920,14 @@ of." (tramp-error v 'file-already-exists filename)) (let ((tmpfile (tramp-compat-make-temp-file filename)) - (modes (save-excursion (tramp-default-file-modes filename)))) + (modes (tramp-default-file-modes + filename (and (eq mustbenew 'excl) 'nofollow))) + (uid (or (tramp-compat-file-attribute-user-id + (file-attributes filename 'integer)) + (tramp-get-remote-uid v 'integer))) + (gid (or (tramp-compat-file-attribute-group-id + (file-attributes filename 'integer)) + (tramp-get-remote-gid v 'integer)))) (when (and append (file-exists-p filename)) (copy-file filename tmpfile 'ok)) ;; The permissions of the temporary file should be set. If @@ -3881,15 +3946,18 @@ of." (error (delete-file tmpfile) (tramp-error - v 'file-error "Couldn't write region to `%s'" filename)))) + v 'file-error "Couldn't write region to `%s'" filename))) - (tramp-flush-file-properties v localname) + (tramp-flush-file-properties v localname) - ;; Set file modification time. - (when (or (eq visit t) (stringp visit)) - (set-visited-file-modtime - (tramp-compat-file-attribute-modification-time - (file-attributes filename)))) + ;; Set file modification time. + (when (or (eq visit t) (stringp visit)) + (set-visited-file-modtime + (tramp-compat-file-attribute-modification-time + (file-attributes filename)))) + + ;; Set the ownership. + (tramp-set-file-uid-gid filename uid gid)) ;; The end. (when (and (null noninteractive) @@ -3943,7 +4011,7 @@ of." "Call `file-notify-rm-watch'." (unless (process-live-p proc) (tramp-message proc 5 "Sentinel called: `%S' `%s'" proc event) - (tramp-compat-funcall 'file-notify-rm-watch proc))) + (file-notify-rm-watch proc))) ;;; Functions for establishing connection: @@ -4044,6 +4112,8 @@ The terminal type can be configured with `tramp-terminal-type'." (defun tramp-action-process-alive (proc _vec) "Check, whether a process has finished." (unless (process-live-p proc) + ;; There might be pending output. + (while (tramp-accept-process-output proc 0)) (throw 'tramp-action 'process-died))) (defun tramp-action-out-of-band (proc vec) @@ -4083,9 +4153,9 @@ See `tramp-process-actions' for the format of ACTIONS." (while (tramp-accept-process-output proc 0)) (setq todo actions) (while todo - (setq item (pop todo)) - (setq pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item)))) - (setq action (nth 1 item)) + (setq item (pop todo) + pattern (format "\\(%s\\)\\'" (symbol-value (nth 0 item))) + action (nth 1 item)) (tramp-message vec 5 "Looking for regexp \"%s\" from remote shell" pattern) (when (tramp-check-for-regexp proc pattern) @@ -4135,9 +4205,8 @@ performed successfully. Any other value means an error." (catch 'tramp-action (tramp-process-one-action proc vec actions))))) (while (not exit) - (setq exit - (catch 'tramp-action - (tramp-process-one-action proc vec actions))))) + (setq exit (catch 'tramp-action + (tramp-process-one-action proc vec actions))))) (with-current-buffer (tramp-get-connection-buffer vec) (widen) (tramp-message vec 6 "\n%s" (buffer-string))) @@ -4158,10 +4227,9 @@ performed successfully. Any other value means an error." (tramp-get-connection-buffer vec))) ((eq exit 'process-died) (substitute-command-keys - (eval-when-compile - (concat - "Tramp failed to connect. If this happens repeatedly, try\n" - " `\\[tramp-cleanup-this-connection]'")))) + (concat + "Tramp failed to connect. If this happens repeatedly, try\n" + " `\\[tramp-cleanup-this-connection]'"))) ((eq exit 'timeout) (format-message "Timeout reached, see buffer `%s' for details" @@ -4176,18 +4244,21 @@ performed successfully. Any other value means an error." (defun tramp-accept-process-output (proc &optional timeout) "Like `accept-process-output' for Tramp processes. This is needed in order to hide `last-coding-system-used', which is set -for process communication also." +for process communication also. +If the user quits via `C-g', it is propagated up to `tramp-file-name-handler'." (with-current-buffer (process-buffer proc) (let ((inhibit-read-only t) last-coding-system-used result) - ;; JUST-THIS-ONE is set due to Bug#12145. - (tramp-message - proc 10 "%s %s %s %s\n%s" - proc timeout (process-status proc) - (with-local-quit - (setq result (accept-process-output proc timeout nil t))) - (buffer-string)) + ;; JUST-THIS-ONE is set due to Bug#12145. `with-local-quit' + ;; returns t in order to report success. + (if (with-local-quit + (setq result (accept-process-output proc timeout nil t)) t) + (tramp-message + proc 10 "%s %s %s %s\n%s" + proc timeout (process-status proc) result (buffer-string)) + ;; Propagate quit. + (keyboard-quit)) result))) (defun tramp-search-regexp (regexp) @@ -4362,7 +4433,7 @@ would yield t. On the other hand, the following check results in nil: (tramp-equal-remote \"/sudo::/etc\" \"/su::/etc\") If both files are local, the function returns t." - (or (and (null (file-remote-p file1)) (null (file-remote-p file2))) + (or (and (null (tramp-tramp-file-p file1)) (null (tramp-tramp-file-p file2))) (and (tramp-tramp-file-p file1) (tramp-tramp-file-p file2) (string-equal (file-remote-p file1) (file-remote-p file2))))) @@ -4455,9 +4526,9 @@ This is used to map a mode number to a permission string.") (suid (> (logand (ash mode -9) 4) 0)) (sgid (> (logand (ash mode -9) 2) 0)) (sticky (> (logand (ash mode -9) 1) 0))) - (setq user (tramp-file-mode-permissions user suid "s")) - (setq group (tramp-file-mode-permissions group sgid "s")) - (setq other (tramp-file-mode-permissions other sticky "t")) + (setq user (tramp-file-mode-permissions user suid "s") + group (tramp-file-mode-permissions group sgid "s") + other (tramp-file-mode-permissions other sticky "t")) (concat type user group other))) (defun tramp-file-mode-permissions (perm suid suid-text) @@ -4487,16 +4558,15 @@ If FILENAME is remote, a file name handler is called." (when (and modes (not (zerop (logand modes #o2000)))) (setq gid (tramp-compat-file-attribute-group-id (file-attributes dir))))) - (let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) - (if handler - (funcall handler #'tramp-set-file-uid-gid filename uid gid) - ;; On W32 systems, "chown" does not work. - (unless (memq system-type '(ms-dos windows-nt)) - (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) - (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) - (tramp-call-process - nil "chown" nil nil nil (format "%d:%d" uid gid) - (tramp-unquote-shell-quote-argument filename))))))) + (if-let ((handler (find-file-name-handler filename 'tramp-set-file-uid-gid))) + (funcall handler #'tramp-set-file-uid-gid filename uid gid) + ;; On W32 systems, "chown" does not work. + (unless (memq system-type '(ms-dos windows-nt)) + (let ((uid (or (and (natnump uid) uid) (tramp-get-local-uid 'integer))) + (gid (or (and (natnump gid) gid) (tramp-get-local-gid 'integer)))) + (tramp-call-process + nil "chown" nil nil nil (format "%d:%d" uid gid) + (tramp-unquote-shell-quote-argument filename)))))) (defun tramp-get-local-uid (id-format) "The uid of the local user, in ID-FORMAT. @@ -4562,12 +4632,8 @@ be granted." (concat "file-attributes-" suffix) nil) (file-attributes (tramp-make-tramp-file-name vec) (intern suffix)))) - (remote-uid - (tramp-get-connection-property - vec (concat "uid-" suffix) nil)) - (remote-gid - (tramp-get-connection-property - vec (concat "gid-" suffix) nil)) + (remote-uid (tramp-get-remote-uid vec (intern suffix))) + (remote-gid (tramp-get-remote-gid vec (intern suffix))) (unknown-id (if (string-equal suffix "string") tramp-unknown-id-string tramp-unknown-id-integer))) @@ -4601,6 +4667,32 @@ be granted." (tramp-compat-file-attribute-group-id file-attr)))))))))))) +(defun tramp-get-remote-uid (vec id-format) + "The uid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "uid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-uid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + +(defun tramp-get-remote-gid (vec id-format) + "The gid of the remote connection VEC, in ID-FORMAT. +ID-FORMAT valid values are `string' and `integer'." + (with-tramp-connection-property vec (format "gid-%s" id-format) + (or (when-let + ((handler + (find-file-name-handler + (tramp-make-tramp-file-name vec) 'tramp-get-remote-uid))) + (funcall handler #'tramp-get-remote-gid vec id-format)) + ;; Ensure there is a valid result. + (and (equal id-format 'integer) tramp-unknown-id-integer) + (and (equal id-format 'string) tramp-unknown-id-string)))) + (defun tramp-local-host-p (vec) "Return t if this points to the local host, nil otherwise. This handles also chrooted environments, which are not regarded as local." @@ -4615,15 +4707,15 @@ This handles also chrooted environments, which are not regarded as local." ;; handlers. `tramp-local-host-p' is also called for "smb" and ;; alike, where it must fail. (tramp-get-method-parameter vec 'tramp-login-program) + ;; Direct actions aren't possible for crypted directories. + (null tramp-crypt-enabled) ;; The local temp directory must be writable for the other user. (file-writable-p (tramp-make-tramp-file-name vec (tramp-compat-temporary-file-directory) 'nohop)) ;; On some systems, chown runs only for root. (or (zerop (user-uid)) - ;; This is defined in tramp-sh.el. Let's assume this is - ;; loaded already. - (zerop (tramp-compat-funcall 'tramp-get-remote-uid vec 'integer)))))) + (zerop (tramp-get-remote-uid vec 'integer)))))) (defun tramp-get-remote-tmpdir (vec) "Return directory for temporary files on the remote host identified by VEC." @@ -4632,22 +4724,25 @@ This handles also chrooted environments, which are not regarded as local." (tramp-make-tramp-file-name vec (or (tramp-get-method-parameter vec 'tramp-tmpdir) "/tmp")))) (or (and (file-directory-p dir) (file-writable-p dir) - (tramp-compat-file-local-name dir)) + (tramp-file-local-name dir)) (tramp-error vec 'file-error "Directory %s not accessible" dir)) dir))) +(defun tramp-make-tramp-temp-name (vec) + "Generate a temporary file name on the remote host identified by VEC." + (make-temp-name + (expand-file-name tramp-temp-name-prefix (tramp-get-remote-tmpdir vec)))) + (defun tramp-make-tramp-temp-file (vec) "Create a temporary file on the remote host identified by VEC. Return the local name of the temporary file." - (let ((prefix (expand-file-name - tramp-temp-name-prefix (tramp-get-remote-tmpdir vec))) - result) + (let (result) (while (not result) ;; `make-temp-file' would be the natural choice for ;; implementation. But it calls `write-region' internally, ;; which also needs a temporary file - we would end in an ;; infinite loop. - (setq result (make-temp-name prefix)) + (setq result (tramp-make-tramp-temp-name vec)) (if (file-exists-p result) (setq result nil) ;; This creates the file by side effect. @@ -4655,7 +4750,7 @@ Return the local name of the temporary file." (set-file-modes result #o0700))) ;; Return the local part. - (with-parsed-tramp-file-name result nil localname))) + (tramp-file-local-name result))) (defun tramp-delete-temp-file-function () "Remove temporary files related to current buffer." @@ -4682,7 +4777,7 @@ this file, if that variable is non-nil." (let ((system-type (if (and (stringp tramp-auto-save-directory) - (file-remote-p tramp-auto-save-directory)) + (tramp-tramp-file-p tramp-auto-save-directory)) 'not-windows system-type)) (auto-save-file-name-transforms @@ -4820,11 +4915,29 @@ verbosity of 6." (tramp-message vec 6 "%s" result) result)) +(defun tramp-process-running-p (process-name) + "Return t if system process PROCESS-NAME is running for `user-login-name'." + (when (stringp process-name) + (catch 'result + (dolist (pid (list-system-processes)) + (when-let ((attributes (process-attributes pid)) + (comm (cdr (assoc 'comm attributes)))) + (and (string-equal (cdr (assoc 'user attributes)) (user-login-name)) + ;; The returned command name could be truncated to 15 + ;; characters. Therefore, we cannot check for `string-equal'. + (string-prefix-p comm process-name) + (throw 'result t))))))) + (defun tramp-read-passwd (proc &optional prompt) "Read a password from user (compat function). Consults the auth-source package. Invokes `password-read' if available, `read-passwd' else." - (let* ((case-fold-search t) + (let* (;; If `auth-sources' contains "~/.authinfo.gpg", and + ;; `exec-path' contains a relative file name like ".", it + ;; could happen that the "gpg" command is not found. So we + ;; adapt `default-directory'. (Bug#39389, Bug#39489) + (default-directory (tramp-compat-temporary-file-directory)) + (case-fold-search t) (key (tramp-make-tramp-file-name ;; In tramp-sh.el, we must use "password-vector" due to ;; multi-hop. @@ -4976,10 +5089,12 @@ name of a process or buffer, or nil to default to the current buffer." (tramp-error proc 'error "Process %s is not active" proc) (tramp-message proc 5 "Interrupt process %s with pid %s" proc pid) ;; This is for tramp-sh.el. Other backends do not support this (yet). + ;; Not all "kill" implementations support process groups by + ;; negative pid, so we try both variants. (tramp-compat-funcall 'tramp-send-command (process-get proc 'vector) - (format "kill -2 -%d" pid)) + (format "(\\kill -2 -%d || \\kill -2 %d) 2>/dev/null" pid pid)) ;; Wait, until the process has disappeared. If it doesn't, ;; fall back to the default implementation. (while (tramp-accept-process-output proc 0)) @@ -4993,6 +5108,23 @@ name of a process or buffer, or nil to default to the current buffer." (lambda () (remove-hook 'interrupt-process-functions #'tramp-interrupt-process)))) +(defun tramp-get-signal-strings () + "Strings to return by `process-file' in case of signals." + ;; We use key nil for local connection properties. + (with-tramp-connection-property nil "signal-strings" + (let (result) + (if (and (stringp shell-file-name) (executable-find shell-file-name)) + (dotimes (i 128) + (push + (if (= i 19) 1 ;; SIGSTOP + (call-process + shell-file-name nil nil nil "-c" (format "kill -%d $$" i))) + result)) + (dotimes (i 128) + (push (format "Signal %d" i) result))) + ;; Due to Bug#41287, we cannot add this to the `dotimes' clause. + (reverse result)))) + ;; Checklist for `tramp-unload-hook' ;; - Unload all `tramp-*' packages ;; - Reset `file-name-handler-alist' @@ -5034,16 +5166,5 @@ name of a process or buffer, or nil to default to the current buffer." ;; and friends, for most of the handlers this is the major ;; difference between the different backends. Other handlers but ;; *-process-file would profit from this as well. -;; -;; * Get rid of `shell-command'. In its primary implementation, it -;; uses `process-file-shell-command' and -;; `start-file-process-shell-command', which is sufficient due to -;; connection-local `shell-file-name'. - ;;; tramp.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/trampver.el b/lisp/net/trampver.el index dacdd44102f..8d21133b3b1 100644 --- a/lisp/net/trampver.el +++ b/lisp/net/trampver.el @@ -35,11 +35,8 @@ ;; Emacs version check is defined in macro AC_EMACS_INFO of ;; aclocal.m4; should be changed only there. -;; Needed for Emacs 24. -(defvar inhibit-message) - ;;;###tramp-autoload -(defconst tramp-version "2.4.3.27.1" +(defconst tramp-version "2.5.0-pre" "This version of Tramp.") ;;;###tramp-autoload @@ -51,6 +48,7 @@ ;; Suppress message from `emacs-repository-get-branch'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) ;; `emacs-repository-get-branch' has been introduced with Emacs 27.1. @@ -64,6 +62,7 @@ ;; Suppress message from `emacs-repository-get-version'. We must ;; also handle out-of-tree builds. (let ((inhibit-message t) + (debug-on-error nil) (dir (or (locate-dominating-file (locate-library "tramp") ".git") source-directory))) (and (stringp dir) (file-directory-p dir) @@ -71,9 +70,9 @@ "The repository revision of the Tramp sources.") ;; Check for Emacs version. -(let ((x (if (not (string-lessp emacs-version "24.4")) +(let ((x (if (not (string-lessp emacs-version "25.1")) "ok" - (format "Tramp 2.4.3.27.1 is not fit for %s" + (format "Tramp 2.5.0-pre is not fit for %s" (replace-regexp-in-string "\n" "" (emacs-version)))))) (unless (string-equal "ok" x) (error "%s" x))) @@ -102,8 +101,3 @@ (provide 'trampver) ;;; trampver.el ends here - -;; Local Variables: -;; mode: Emacs-Lisp -;; coding: utf-8 -;; End: diff --git a/lisp/net/webjump.el b/lisp/net/webjump.el index 6edd03c39cc..8bb156199c5 100644 --- a/lisp/net/webjump.el +++ b/lisp/net/webjump.el @@ -1,4 +1,4 @@ -;;; webjump.el --- programmable Web hotlist +;;; webjump.el --- programmable Web hotlist -*- lexical-binding: t; -*- ;; Copyright (C) 1996-1997, 2001-2020 Free Software Foundation, Inc. @@ -323,8 +323,7 @@ Please submit bug reports and other feedback to the author, Neil W. Van Dyke (defun webjump-read-url-choice (what urls &optional default) ;; Note: Convert this to use `webjump-read-choice' someday. - (let* ((completions (mapcar (function (lambda (n) (cons n n))) - urls)) + (let* ((completions (mapcar (lambda (n) (cons n n)) urls)) (input (completing-read (concat what ;;(if default " (RET for default)" "") ": ") diff --git a/lisp/obsolete/cust-print.el b/lisp/obsolete/cust-print.el index fbf80692037..40532ea5b9d 100644 --- a/lisp/obsolete/cust-print.el +++ b/lisp/obsolete/cust-print.el @@ -156,10 +156,7 @@ If nil, printing proceeds recursively and may lead to If non-nil, shared substructures anywhere in the structure are printed with `#N=' before the first occurrence (in the order of the print representation) and `#N#' in place of each subsequent occurrence, -where N is a positive decimal integer. - -There is no way to read this representation in standard Emacs, -but if you need to do so, try the cl-read.el package." +where N is a positive decimal integer." :type 'boolean :group 'cust-print) diff --git a/lisp/obsolete/iswitchb.el b/lisp/obsolete/iswitchb.el index 350eabdb0c1..96b063be701 100644 --- a/lisp/obsolete/iswitchb.el +++ b/lisp/obsolete/iswitchb.el @@ -1393,7 +1393,7 @@ Copied from `icomplete-tidy'." "Move the summaries to the end of the list. This is an example function which can be hooked on to `iswitchb-make-buflist-hook'. Any buffer matching the regexps -`Summary' or `output\*$'are put to the end of the list." +`Summary' or `output\\*$'are put to the end of the list." (let ((summaries (delq nil (mapcar (lambda (x) diff --git a/lisp/obsolete/ledit.el b/lisp/obsolete/ledit.el deleted file mode 100644 index c99a06de570..00000000000 --- a/lisp/obsolete/ledit.el +++ /dev/null @@ -1,157 +0,0 @@ -;;; ledit.el --- Emacs side of ledit interface - -;; Copyright (C) 1985, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: languages -;; Obsolete-since: 24.3 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This is a major mode for editing Liszt. - -;;; Code: - -;;; To do: -;;; o lisp -> emacs side of things (grind-definition and find-definition) - -(defvar ledit-mode-map nil) - -(defconst ledit-zap-file - (expand-file-name (concat (user-login-name) ".l1") temporary-file-directory) - "File name for data sent to Lisp by Ledit.") -(defconst ledit-read-file - (expand-file-name (concat (user-login-name) ".l2") temporary-file-directory) - "File name for data sent to Ledit by Lisp.") -(defconst ledit-compile-file - (expand-file-name (concat (user-login-name) ".l4") temporary-file-directory) - "File name for data sent to Lisp compiler by Ledit.") -(defconst ledit-buffer "*LEDIT*" - "Name of buffer in which Ledit accumulates data to send to Lisp.") - -;;;###autoload -(defconst ledit-save-files t "\ -*Non-nil means Ledit should save files before transferring to Lisp.") -;;;###autoload -(defconst ledit-go-to-lisp-string "%?lisp" "\ -*Shell commands to execute to resume Lisp job.") -;;;###autoload -(defconst ledit-go-to-liszt-string "%?liszt" "\ -*Shell commands to execute to resume Lisp compiler job.") - -(defun ledit-save-defun () - "Save the current defun in the ledit buffer." - (interactive) - (save-excursion - (end-of-defun) - (let ((end (point))) - (beginning-of-defun) - (append-to-buffer ledit-buffer (point) end)) - (message "Current defun saved for Lisp"))) - -(defun ledit-save-region (beg end) - "Save the current region in the ledit buffer" - (interactive "r") - (append-to-buffer ledit-buffer beg end) - (message "Region saved for Lisp")) - -(defun ledit-zap-defun-to-lisp () - "Carry the current defun to Lisp." - (interactive) - (ledit-save-defun) - (ledit-go-to-lisp)) - -(defun ledit-zap-defun-to-liszt () - "Carry the current defun to liszt." - (interactive) - (ledit-save-defun) - (ledit-go-to-liszt)) - -(defun ledit-zap-region-to-lisp (beg end) - "Carry the current region to Lisp." - (interactive "r") - (ledit-save-region beg end) - (ledit-go-to-lisp)) - -(defun ledit-go-to-lisp () - "Suspend Emacs and restart a waiting Lisp job." - (interactive) - (if ledit-save-files - (save-some-buffers)) - (if (get-buffer ledit-buffer) - (with-current-buffer ledit-buffer - (goto-char (point-min)) - (write-region (point-min) (point-max) ledit-zap-file) - (erase-buffer))) - (suspend-emacs ledit-go-to-lisp-string) - (load ledit-read-file t t)) - -(defun ledit-go-to-liszt () - "Suspend Emacs and restart a waiting Liszt job." - (interactive) - (if ledit-save-files - (save-some-buffers)) - (if (get-buffer ledit-buffer) - (with-current-buffer ledit-buffer - (goto-char (point-min)) - (insert "(declare (macros t))\n") - (write-region (point-min) (point-max) ledit-compile-file) - (erase-buffer))) - (suspend-emacs ledit-go-to-liszt-string) - (load ledit-read-file t t)) - -(defun ledit-setup () - "Set up key bindings for the Lisp/Emacs interface." - (unless ledit-mode-map - (setq ledit-mode-map (make-sparse-keymap)) - (set-keymap-parent ledit-mode-map lisp-mode-shared-map)) - (define-key ledit-mode-map "\e\^d" 'ledit-save-defun) - (define-key ledit-mode-map "\e\^r" 'ledit-save-region) - (define-key ledit-mode-map "\^xz" 'ledit-go-to-lisp) - (define-key ledit-mode-map "\e\^c" 'ledit-go-to-liszt)) - -(ledit-setup) - -;;;###autoload -(defun ledit-mode () - "\\<ledit-mode-map>Major mode for editing text and stuffing it to a Lisp job. -Like Lisp mode, plus these special commands: - \\[ledit-save-defun] -- record defun at or after point - for later transmission to Lisp job. - \\[ledit-save-region] -- record region for later transmission to Lisp job. - \\[ledit-go-to-lisp] -- transfer to Lisp job and transmit saved text. - \\[ledit-go-to-liszt] -- transfer to Liszt (Lisp compiler) job - and transmit saved text. - -\\{ledit-mode-map} -To make Lisp mode automatically change to Ledit mode, -do (setq lisp-mode-hook 'ledit-from-lisp-mode)" - (interactive) - (delay-mode-hooks (lisp-mode)) - (ledit-from-lisp-mode)) - -;;;###autoload -(defun ledit-from-lisp-mode () - (use-local-map ledit-mode-map) - (setq mode-name "Ledit") - (setq major-mode 'ledit-mode) - (run-mode-hooks 'ledit-mode-hook)) - -(provide 'ledit) - -;;; ledit.el ends here diff --git a/lisp/obsolete/levents.el b/lisp/obsolete/levents.el deleted file mode 100644 index 2ae1ca48d16..00000000000 --- a/lisp/obsolete/levents.el +++ /dev/null @@ -1,292 +0,0 @@ -;;; levents.el --- emulate the Lucid event data type and associated functions - -;; Copyright (C) 1993, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: emulations -;; Obsolete-since: 23.2 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; Things we cannot emulate in Lisp: -;; It is not possible to emulate current-mouse-event as a variable, -;; though it is not hard to obtain the data from (this-command-keys). - -;; We do not have a variable unread-command-event; -;; instead, we have the more general unread-command-events. - -;; Our read-key-sequence and read-char are not precisely -;; compatible with those in Lucid Emacs, but they should work ok. - -;;; Code: - -(defun next-command-event (event) - (error "You must rewrite to use `read-command-event' instead of `next-command-event'")) - -(defun next-event (event) - (error "You must rewrite to use `read-event' instead of `next-event'")) - -(defun dispatch-event (event) - (error "`dispatch-event' not supported")) - -;; Make events of type eval, menu and timeout -;; execute properly. - -(define-key global-map [menu] 'execute-eval-event) -(define-key global-map [timeout] 'execute-eval-event) -(define-key global-map [eval] 'execute-eval-event) - -(defun execute-eval-event (event) - (interactive "e") - (funcall (nth 1 event) (nth 2 event))) - -(put 'eval 'event-symbol-elements '(eval)) -(put 'menu 'event-symbol-elements '(eval)) -(put 'timeout 'event-symbol-elements '(eval)) - -(defun allocate-event () - "Return an empty event structure. -In this emulation, it returns nil." - nil) - -(defun button-press-event-p (obj) - "True if the argument is a mouse-button-press event object." - (and (consp obj) (symbolp (car obj)) - (memq 'down (get (car obj) 'event-symbol-elements)))) - -(defun button-release-event-p (obj) - "True if the argument is a mouse-button-release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun button-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun mouse-event-p (obj) - "True if the argument is a mouse-button press or release event object." - (and (consp obj) (symbolp (car obj)) - (or (eq (car obj) 'mouse-movement) - (memq 'click (get (car obj) 'event-symbol-elements)) - (memq 'down (get (car obj) 'event-symbol-elements)) - (memq 'drag (get (car obj) 'event-symbol-elements))))) - -(defun character-to-event (ch &optional event) - "Converts a numeric ASCII value to an event structure, replete with -bucky bits. The character is the first argument, and the event to fill -in is the second. This function contains knowledge about what the codes -mean -- for example, the number 9 is converted to the character Tab, -not the distinct character Control-I. - -Beware that character-to-event and event-to-character are not strictly -inverse functions, since events contain much more information than the -ASCII character set can encode." - ch) - -(defun copy-event (event1 &optional event2) - "Make a copy of the given event object. -In this emulation, `copy-event' just returns its argument." - event1) - -(defun deallocate-event (event) - "Allow the given event structure to be reused. -In actual Lucid Emacs, you MUST NOT use this event object after -calling this function with it. You will lose. It is not necessary to -call this function, as event objects are garbage- collected like all -other objects; however, it may be more efficient to explicitly -deallocate events when you are sure that this is safe. - -This emulation does not actually deallocate or reuse events -except via garbage collection and `cons'." - nil) - -(defun enqueue-eval-event: (function object) - "Add an eval event to the back of the queue. -It will be the next event read after all pending events." - (setq unread-command-events - (nconc unread-command-events - (list (list 'eval function object))))) - -(defun eval-event-p (obj) - "True if the argument is an eval or menu event object." - (eq (car-safe obj) 'eval)) - -(defun event-button (event) - "Return the button-number of the given mouse-button-press event." - (let ((sym (car (get (car event) 'event-symbol-elements)))) - (cdr (assq sym '((mouse-1 . 1) (mouse-2 . 2) (mouse-3 . 3) - (mouse-4 . 4) (mouse-5 . 5)))))) - -(defun event-function (event) - "Return the callback function of the given timeout, menu, or eval event." - (nth 1 event)) - -(defun event-key (event) - "Return the KeySym of the given key-press event. -The value is an ASCII printing character (not upper case) or a symbol." - (if (symbolp event) - (car (get event 'event-symbol-elements)) - (let ((base (logand event (1- (ash 1 18))))) - (downcase (if (< base 32) (logior base 64) base))))) - -(defun event-object (event) - "Return the function argument of the given timeout, menu, or eval event." - (nth 2 event)) - -(defun event-point (event) - "Return the character position of the given mouse-related event. -If the event did not occur over a window, or did -not occur over text, then this returns nil. Otherwise, it returns an index -into the buffer visible in the event's window." - (posn-point (event-end event))) - -;; Return position of start of line LINE in WINDOW. -;; If LINE is nil, return the last position -;; visible in WINDOW. -(defun event-closest-point-1 (window &optional line) - (let* ((total (- (window-height window) - (if (window-minibuffer-p window) - 0 1))) - (distance (or line total))) - (save-excursion - (goto-char (window-start window)) - (if (= (vertical-motion distance) distance) - (if (not line) - (forward-char -1))) - (point)))) - -(defun event-closest-point (event &optional start-window) - "Return the nearest position to where EVENT ended its motion. -This is computed for the window where EVENT's motion started, -or for window WINDOW if that is specified." - (or start-window (setq start-window (posn-window (event-start event)))) - (if (eq start-window (posn-window (event-end event))) - (if (eq (event-point event) 'vertical-line) - (event-closest-point-1 start-window - (cdr (posn-col-row (event-end event)))) - (if (eq (event-point event) 'mode-line) - (event-closest-point-1 start-window) - (event-point event))) - ;; EVENT ended in some other window. - (let* ((end-w (posn-window (event-end event))) - (end-w-top) - (w-top (nth 1 (window-edges start-window)))) - (setq end-w-top - (if (windowp end-w) - (nth 1 (window-edges end-w)) - (/ (cdr (posn-x-y (event-end event))) - (frame-char-height end-w)))) - (if (>= end-w-top w-top) - (event-closest-point-1 start-window) - (window-start start-window))))) - -(defun event-process (event) - "Return the process of the given process-output event." - (nth 1 event)) - -(defun event-timestamp (event) - "Return the timestamp of the given event object. -In Lucid Emacs, this works for any kind of event. -In this emulation, it returns nil for non-mouse-related events." - (and (listp event) - (posn-timestamp (event-end event)))) - -(defun event-to-character (event &optional lenient) - "Return the closest ASCII approximation to the given event object. -If the event isn't a keypress, this returns nil. -If the second argument is non-nil, then this is lenient in its -translation; it will ignore modifier keys other than control and meta, -and will ignore the shift modifier on those characters which have no -shifted ASCII equivalent (Control-Shift-A for example, will be mapped to -the same ASCII code as Control-A.) If the second arg is nil, then nil -will be returned for events which have no direct ASCII equivalent." - (if (symbolp event) - (and lenient - (cdr (assq event '((backspace . 8) (delete . 127) (tab . 9) - (return . 10) (enter . 10))))) - ;; Our interpretation is, ASCII means anything a number can represent. - (if (integerp event) - event nil))) - -(defun event-window (event) - "Return the window of the given mouse-related event object." - (posn-window (event-end event))) - -(defun event-x (event) - "Return the X position in characters of the given mouse-related event." - (/ (car (posn-col-row (event-end event))) - (frame-char-width (window-frame (event-window event))))) - -(defun event-x-pixel (event) - "Return the X position in pixels of the given mouse-related event." - (car (posn-col-row (event-end event)))) - -(defun event-y (event) - "Return the Y position in characters of the given mouse-related event." - (/ (cdr (posn-col-row (event-end event))) - (frame-char-height (window-frame (event-window event))))) - -(defun event-y-pixel (event) - "Return the Y position in pixels of the given mouse-related event." - (cdr (posn-col-row (event-end event)))) - -(defun key-press-event-p (obj) - "True if the argument is a keyboard event object." - (or (integerp obj) - (and (symbolp obj) - (get obj 'event-symbol-elements)))) - -(defun menu-event-p (obj) - "True if the argument is a menu event object." - (eq (car-safe obj) 'menu)) - -(defun motion-event-p (obj) - "True if the argument is a mouse-motion event object." - (eq (car-safe obj) 'mouse-movement)) - -(defun read-command-event () - "Return the next keyboard or mouse event; execute other events. -This is similar to the function `next-command-event' of Lucid Emacs, -but different in that it returns the event rather than filling in -an existing event object." - (let (event) - (while (progn - (setq event (read-event)) - (not (or (key-press-event-p event) - (button-press-event-p event) - (button-release-event-p event) - (menu-event-p event)))) - (let ((type (car-safe event))) - (cond ((eq type 'eval) - (funcall (nth 1 event) (nth 2 event))) - ((eq type 'switch-frame) - (select-frame (nth 1 event)))))) - event)) - -(defun process-event-p (obj) - "True if the argument is a process-output event object. -GNU Emacs 19 does not currently generate process-output events." - (eq (car-safe obj) 'process)) - -(provide 'levents) - -;;; levents.el ends here diff --git a/lisp/obsolete/lmenu.el b/lisp/obsolete/lmenu.el deleted file mode 100644 index 678481924b2..00000000000 --- a/lisp/obsolete/lmenu.el +++ /dev/null @@ -1,445 +0,0 @@ -;;; lmenu.el --- emulate Lucid's menubar support - -;; Copyright (C) 1992-1994, 1997, 2001-2020 Free Software Foundation, -;; Inc. - -;; Keywords: emulations obsolete -;; Obsolete-since: 23.3 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; This file has been obsolete since Emacs 23.3. - -;;; Code: - - -;; First, emulate the Lucid menubar support in GNU Emacs 19. - -;; Arrange to use current-menubar to set up part of the menu bar. - -(defvar current-menubar) -(defvar lucid-menubar-map) -(defvar lucid-failing-menubar) - -(defvar recompute-lucid-menubar 'recompute-lucid-menubar) -(defun recompute-lucid-menubar () - (define-key lucid-menubar-map [menu-bar] - (condition-case nil - (make-lucid-menu-keymap "menu-bar" current-menubar) - (error (message "Invalid data in current-menubar moved to lucid-failing-menubar") - (sit-for 1) - (setq lucid-failing-menubar current-menubar - current-menubar nil)))) - (setq lucid-menu-bar-dirty-flag nil)) - -(defvar lucid-menubar-map (make-sparse-keymap)) -(or (assq 'current-menubar minor-mode-map-alist) - (setq minor-mode-map-alist - (cons (cons 'current-menubar lucid-menubar-map) - minor-mode-map-alist))) - -;; XEmacs compatibility -(defun set-menubar-dirty-flag () - (force-mode-line-update) - (setq lucid-menu-bar-dirty-flag t)) - -(defvar add-menu-item-count 0) - -;; This is a variable whose value is always nil. -(defvar make-lucid-menu-keymap-disable nil) - -;; Return a menu keymap corresponding to a Lucid-style menu list -;; MENU-ITEMS, and with name MENU-NAME. -(defun make-lucid-menu-keymap (menu-name menu-items) - (let ((menu (make-sparse-keymap menu-name))) - ;; Process items in reverse order, - ;; since the define-key loop reverses them again. - (setq menu-items (reverse menu-items)) - (while menu-items - (let ((item (car menu-items)) - command name callback) - (cond ((stringp item) - (setq command nil) - (setq name (if (string-match "^-+$" item) "" item))) - ((consp item) - (setq command (make-lucid-menu-keymap (car item) (cdr item))) - (setq name (car item))) - ((vectorp item) - (setq command (make-symbol (format "menu-function-%d" - add-menu-item-count)) - add-menu-item-count (1+ add-menu-item-count) - name (aref item 0) - callback (aref item 1)) - (if (symbolp callback) - (fset command callback) - (fset command (list 'lambda () '(interactive) callback))) - (put command 'menu-alias t) - (let ((i 2)) - (while (< i (length item)) - (cond - ((eq (aref item i) ':active) - (put command 'menu-enable - (or (aref item (1+ i)) - 'make-lucid-menu-keymap-disable)) - (setq i (+ 2 i))) - ((eq (aref item i) ':suffix) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':keys) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':style) - ;; unimplemented - (setq i (+ 2 i))) - ((eq (aref item i) ':selected) - ;; unimplemented - (setq i (+ 2 i))) - ((and (symbolp (aref item i)) - (= ?: (string-to-char (symbol-name (aref item i))))) - (error "Unrecognized menu item keyword: %S" - (aref item i))) - ((= i 2) - ;; old-style format: active-p &optional suffix - (put command 'menu-enable - (or (aref item i) 'make-lucid-menu-keymap-disable)) - ;; suffix is unimplemented - (setq i (length item))) - (t - (error "Unexpected menu item value: %S" - (aref item i)))))))) - (if (null command) - ;; Handle inactive strings specially--allow any number - ;; of identical ones. - (setcdr menu (cons (list nil name) (cdr menu))) - (if name - (define-key menu (vector (intern name)) (cons name command))))) - (setq menu-items (cdr menu-items))) - menu)) - -(declare-function x-popup-dialog "menu.c" (position contents &optional header)) - -;; XEmacs compatibility function -(defun popup-dialog-box (data) - "Pop up a dialog box. -A dialog box description is a list. - - - The first element of the list is a string to display in the dialog box. - - The rest of the elements are descriptions of the dialog box's buttons. - Each one is a vector of three elements: - - The first element is the text of the button. - - The second element is the `callback'. - - The third element is t or nil, whether this button is selectable. - -If the `callback' of a button is a symbol, then it must name a command. -It will be invoked with `call-interactively'. If it is a list, then it is -evaluated with `eval'. - -One (and only one) of the buttons may be nil. This marker means that all -following buttons should be flushright instead of flushleft. - -The syntax, more precisely: - - form := <something to pass to `eval'> - command := <a symbol or string, to pass to `call-interactively'> - callback := command | form - active-p := <t, nil, or a form to evaluate to decide whether this - button should be selectable> - name := <string> - partition := `nil' - button := `[' name callback active-p `]' - dialog := `(' name [ button ]+ [ partition [ button ]+ ] `)'" - (let ((name (car data)) - (tail (cdr data)) - converted - choice meaning) - (while tail - (if (null (car tail)) - (setq converted (cons nil converted)) - (let ((item (aref (car tail) 0)) - (callback (aref (car tail) 1)) - (enable (aref (car tail) 2))) - (setq converted - (cons (if enable (cons item callback) item) - converted)))) - (setq tail (cdr tail))) - (setq choice (x-popup-dialog t (cons name (nreverse converted)))) - (if choice - (if (symbolp choice) - (call-interactively choice) - (eval choice))))) - -;; This is empty because the usual elements of the menu bar -;; are provided by menu-bar.el instead. -;; It would not make sense to duplicate them here. -(defconst default-menubar nil) - -;; XEmacs compatibility -(defun set-menubar (menubar) - "Set the default menubar to be menubar." - (setq-default current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - -;; XEmacs compatibility -(defun set-buffer-menubar (menubar) - "Set the buffer-local menubar to be menubar." - (make-local-variable 'current-menubar) - (setq current-menubar (copy-sequence menubar)) - (set-menubar-dirty-flag)) - - -;;; menu manipulation functions - -;; XEmacs compatibility -(defun find-menu-item (menubar item-path-list &optional parent) - "Searches MENUBAR for item given by ITEM-PATH-LIST. -Returns (ITEM . PARENT), where PARENT is the immediate parent of - the item found. -Signals an error if the item is not found." - (or parent (setq item-path-list (mapcar 'downcase item-path-list))) - (if (not (consp menubar)) - nil - (let ((rest menubar) - result) - (while rest - (if (and (car rest) - (equal (car item-path-list) - (downcase (if (vectorp (car rest)) - (aref (car rest) 0) - (if (stringp (car rest)) - (car rest) - (car (car rest))))))) - (setq result (car rest) rest nil) - (setq rest (cdr rest)))) - (if (cdr item-path-list) - (if (consp result) - (find-menu-item (cdr result) (cdr item-path-list) result) - (if result - (signal 'error (list "not a submenu" result)) - (signal 'error (list "no such submenu" (car item-path-list))))) - (cons result parent))))) - - -;; XEmacs compatibility -(defun disable-menu-item (path) - "Make the named menu item be unselectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "can't disable menus, only menu items")) - (aset item 2 nil) - (set-menubar-dirty-flag) - item)) - - -;; XEmacs compatibility -(defun enable-menu-item (path) - "Make the named menu item be selectable. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (consp item) (error "%S is a menu, not a menu item" path)) - (aset item 2 t) - (set-menubar-dirty-flag) - item)) - - -(defun add-menu-item-1 (item-p menu-path item-name item-data enabled-p before) - (if before (setq before (downcase before))) - (let* ((menubar current-menubar) - (menu (condition-case () - (car (find-menu-item menubar menu-path)) - (error nil))) - (item (if (listp menu) - (car (find-menu-item (cdr menu) (list item-name))) - (signal 'error (list "not a submenu" menu-path))))) - (or menu - (let ((rest menu-path) - (so-far menubar)) - (while rest -;;; (setq menu (car (find-menu-item (cdr so-far) (list (car rest))))) - (setq menu - (if (eq so-far menubar) - (car (find-menu-item so-far (list (car rest)))) - (car (find-menu-item (cdr so-far) (list (car rest)))))) - (or menu - (let ((rest2 so-far)) - (or rest2 - (error "Trying to modify a menu that doesn't exist")) - (while (and (cdr rest2) (car (cdr rest2))) - (setq rest2 (cdr rest2))) - (setcdr rest2 - (nconc (list (setq menu (list (car rest)))) - (cdr rest2))))) - (setq so-far menu) - (setq rest (cdr rest))))) - (or menu (setq menu menubar)) - (if item - nil ; it's already there - (if item-p - (setq item (vector item-name item-data enabled-p)) - (setq item (cons item-name item-data))) - ;; if BEFORE is specified, try to add it there. - (if before - (setq before (car (find-menu-item menu (list before))))) - (let ((rest menu) - (added-before nil)) - (while rest - (if (eq before (car (cdr rest))) - (progn - (setcdr rest (cons item (cdr rest))) - (setq rest nil added-before t)) - (setq rest (cdr rest)))) - (if (not added-before) - ;; adding before the first item on the menubar itself is harder - (if (and (eq menu menubar) (eq before (car menu))) - (setq menu (cons item menu) - current-menubar menu) - ;; otherwise, add the item to the end. - (nconc menu (list item)))))) - (if item-p - (progn - (aset item 1 item-data) - (aset item 2 (not (null enabled-p)))) - (setcar item item-name) - (setcdr item item-data)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu-item (menu-path item-name function enabled-p &optional before) - "Add a menu item to some menu, creating the menu first if necessary. -If the named item exists already, it is changed. -MENU-PATH identifies the menu under which the new menu item should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". -ITEM-NAME is the string naming the menu item to be added. -FUNCTION is the command to invoke when this menu item is selected. - If it is a symbol, then it is invoked with `call-interactively', in the same - way that functions bound to keys are invoked. If it is a list, then the - list is simply evaluated. -ENABLED-P controls whether the item is selectable or not. -BEFORE, if provided, is the name of a menu item before which this item should - be added, if this item is not on the menu already. If the item is already - present, it will not be moved." - (or menu-path (error "must specify a menu path")) - (or item-name (error "must specify an item name")) - (add-menu-item-1 t menu-path item-name function enabled-p before)) - - -;; XEmacs compatibility -(defun delete-menu-item (path) - "Remove the named menu item from the menu hierarchy. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\"." - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (or (cdr pair) menubar))) - (if (not item) - nil - ;; the menubar is the only special case, because other menus begin - ;; with their name. - (if (eq menu current-menubar) - (setq current-menubar (delq item menu)) - (delq item menu)) - (set-menubar-dirty-flag) - item))) - - -;; XEmacs compatibility -(defun relabel-menu-item (path new-name) - "Change the string of the specified menu item. -PATH is a list of strings which identify the position of the menu item in -the menu hierarchy. (\"File\" \"Save\") means the menu item called \"Save\" -under the toplevel \"File\" menu. (\"Menu\" \"Foo\" \"Item\") means the -menu item called \"Item\" under the \"Foo\" submenu of \"Menu\". -NEW-NAME is the string that the menu item will be printed as from now on." - (or (stringp new-name) - (setq new-name (signal 'wrong-type-argument (list 'stringp new-name)))) - (let* ((menubar current-menubar) - (pair (find-menu-item menubar path)) - (item (car pair)) - (menu (cdr pair))) - (or item - (signal 'error (list (if menu "No such menu item" "No such menu") - path))) - (if (and (consp item) - (stringp (car item))) - (setcar item new-name) - (aset item 0 new-name)) - (set-menubar-dirty-flag) - item)) - -;; XEmacs compatibility -(defun add-menu (menu-path menu-name menu-items &optional before) - "Add a menu to the menubar or one of its submenus. -If the named menu exists already, it is changed. -MENU-PATH identifies the menu under which the new menu should be inserted. - It is a list of strings; for example, (\"File\") names the top-level \"File\" - menu. (\"File\" \"Foo\") names a hypothetical submenu of \"File\". - If MENU-PATH is nil, then the menu will be added to the menubar itself. -MENU-NAME is the string naming the menu to be added. -MENU-ITEMS is a list of menu item descriptions. - Each menu item should be a vector of three elements: - - a string, the name of the menu item; - - a symbol naming a command, or a form to evaluate; - - and a form whose value determines whether this item is selectable. -BEFORE, if provided, is the name of a menu before which this menu should - be added, if this menu is not on its parent already. If the menu is already - present, it will not be moved." - (or menu-name (error "must specify a menu name")) - (or menu-items (error "must specify some menu items")) - (add-menu-item-1 nil menu-path menu-name menu-items t before)) - - - -(defvar put-buffer-names-in-file-menu t) - - -;; Don't unconditionally enable menu bars; leave that up to the user. -;;(let ((frames (frame-list))) -;; (while frames -;; (modify-frame-parameters (car frames) '((menu-bar-lines . 1))) -;; (setq frames (cdr frames)))) -;;(or (assq 'menu-bar-lines default-frame-alist) -;; (setq default-frame-alist -;; (cons '(menu-bar-lines . 1) default-frame-alist))) - -(set-menubar default-menubar) - -(provide 'lmenu) - -;;; lmenu.el ends here diff --git a/lisp/obsolete/lucid.el b/lisp/obsolete/lucid.el deleted file mode 100644 index 817cc9cfaaa..00000000000 --- a/lisp/obsolete/lucid.el +++ /dev/null @@ -1,211 +0,0 @@ -;;; lucid.el --- emulate some Lucid Emacs functions - -;; Copyright (C) 1993, 1995, 2001-2020 Free Software Foundation, Inc. - -;; Maintainer: emacs-devel@gnu.org -;; Keywords: emulations -;; Obsolete-since: 23.2 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;;; Code: - -;; XEmacs autoloads CL so we might as well make use of it. -(require 'cl) - -(defalias 'current-time-seconds 'current-time) - -(defun real-path-name (name &optional default) - (file-truename (expand-file-name name default))) - -;; It's not clear what to return if the mouse is not in FRAME. -(defun read-mouse-position (frame) - (let ((pos (mouse-position))) - (if (eq (car pos) frame) - (cdr pos)))) - -(defun switch-to-other-buffer (arg) - "Switch to the previous buffer. -With a numeric arg N, switch to the Nth most recent buffer. -With an arg of 0, buries the current buffer at the -bottom of the buffer stack." - (interactive "p") - (if (eq arg 0) - (bury-buffer (current-buffer))) - (switch-to-buffer - (if (<= arg 1) (other-buffer (current-buffer)) - (nth arg - (apply 'nconc - (mapcar - (lambda (buf) - (if (= ?\ (string-to-char (buffer-name buf))) - nil - (list buf))) - (buffer-list))))))) - -(defun device-class (&optional device) - "Return the class (color behavior) of DEVICE. -This will be one of `color', `grayscale', or `mono'. -This function exists for compatibility with XEmacs." - (cond - ((display-color-p device) 'color) - ((display-grayscale-p device) 'grayscale) - (t 'mono))) - -(defalias 'find-face 'facep) -(defalias 'get-face 'facep) -;; internal-try-face-font was removed from faces.el in rev 1.139, 1999/07/21. -;;;(defalias 'try-face-font 'internal-try-face-font) - -(defalias 'exec-to-string 'shell-command-to-string) - - -;; Buffer context - -(defun buffer-syntactic-context (&optional buffer) - "Syntactic context at point in BUFFER. -Either of `string', `comment' or nil. -This is an XEmacs compatibility function." - (with-current-buffer (or buffer (current-buffer)) - (let ((state (syntax-ppss (point)))) - (cond - ((nth 3 state) 'string) - ((nth 4 state) 'comment))))) - - -(defun buffer-syntactic-context-depth (&optional buffer) - "Syntactic parenthesis depth at point in BUFFER. -This is an XEmacs compatibility function." - (with-current-buffer (or buffer (current-buffer)) - (nth 0 (syntax-ppss (point))))) - - -;; Extents -(defun make-extent (beg end &optional buffer) - (make-overlay beg end buffer)) - -(defun extent-properties (extent) (overlay-properties extent)) -(unless (fboundp 'extent-property) (defalias 'extent-property 'overlay-get)) - -(defun extent-at (pos &optional object property before) - (with-current-buffer (or object (current-buffer)) - (let ((overlays (overlays-at pos 'sorted))) - (when property - (let (filtered) - (while overlays - (if (overlay-get (car overlays) property) - (setq filtered (cons (car overlays) filtered))) - (setq overlays (cdr overlays))) - (setq overlays filtered))) - (if before - (nth 1 (memq before overlays)) - (car overlays))))) - -(defun set-extent-property (extent prop value) - ;; Make sure that separate adjacent extents - ;; with the same mouse-face value - ;; do not run together as one extent. - (and (eq prop 'mouse-face) - (symbolp value) - (setq value (list value))) - (if (eq prop 'duplicable) - (cond ((and value (not (overlay-get extent prop))) - ;; If becoming duplicable, copy all overlayprops to text props. - (add-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent))) - ;; If becoming no longer duplicable, remove these text props. - ((and (not value) (overlay-get extent prop)) - (remove-text-properties (overlay-start extent) - (overlay-end extent) - (overlay-properties extent) - (overlay-buffer extent)))) - ;; If extent is already duplicable, put this property - ;; on the text as well as on the overlay. - (if (overlay-get extent 'duplicable) - (put-text-property (overlay-start extent) - (overlay-end extent) - prop value (overlay-buffer extent)))) - (overlay-put extent prop value)) - -(defun set-extent-face (extent face) - (set-extent-property extent 'face face)) - -(defun set-extent-end-glyph (extent glyph) - (set-extent-property extent 'after-string glyph)) - -(defun delete-extent (extent) - (set-extent-property extent 'duplicable nil) - (delete-overlay extent)) - -;; Support the Lucid names with `screen' instead of `frame'. - -(defalias 'current-screen-configuration 'current-frame-configuration) -(defalias 'delete-screen 'delete-frame) -(defalias 'find-file-new-screen 'find-file-other-frame) -(defalias 'find-file-read-only-new-screen 'find-file-read-only-other-frame) -(defalias 'find-tag-new-screen 'find-tag-other-frame) -;;(defalias 'focus-screen 'focus-frame) -(defalias 'iconify-screen 'iconify-frame) -(defalias 'mail-new-screen 'mail-other-frame) -(defalias 'make-screen-invisible 'make-frame-invisible) -(defalias 'make-screen-visible 'make-frame-visible) -;; (defalias 'minibuffer-screen-list 'minibuffer-frame-list) -(defalias 'modify-screen-parameters 'modify-frame-parameters) -(defalias 'next-screen 'next-frame) -;; (defalias 'next-multiscreen-window 'next-multiframe-window) -;; (defalias 'previous-multiscreen-window 'previous-multiframe-window) -;; (defalias 'redirect-screen-focus 'redirect-frame-focus) -(defalias 'redraw-screen 'redraw-frame) -;; (defalias 'screen-char-height 'frame-char-height) -;; (defalias 'screen-char-width 'frame-char-width) -;; (defalias 'screen-configuration-to-register 'frame-configuration-to-register) -;; (defalias 'screen-focus 'frame-focus) -(defalias 'screen-list 'frame-list) -;; (defalias 'screen-live-p 'frame-live-p) -(defalias 'screen-parameters 'frame-parameters) -(defalias 'screen-pixel-height 'frame-pixel-height) -(defalias 'screen-pixel-width 'frame-pixel-width) -(defalias 'screen-root-window 'frame-root-window) -(defalias 'screen-selected-window 'frame-selected-window) -(defalias 'lower-screen 'lower-frame) -(defalias 'raise-screen 'raise-frame) -(defalias 'screen-visible-p 'frame-visible-p) -(defalias 'screenp 'framep) -(defalias 'select-screen 'select-frame) -(defalias 'selected-screen 'selected-frame) -;; (defalias 'set-screen-configuration 'set-frame-configuration) -;; (defalias 'set-screen-height 'set-frame-height) -(defalias 'set-screen-position 'set-frame-position) -(defalias 'set-screen-size 'set-frame-size) -;; (defalias 'set-screen-width 'set-frame-width) -(defalias 'switch-to-buffer-new-screen 'switch-to-buffer-other-frame) -;; (defalias 'unfocus-screen 'unfocus-frame) -(defalias 'visible-screen-list 'visible-frame-list) -(defalias 'window-screen 'window-frame) -(defalias 'x-create-screen 'x-create-frame) -(defalias 'x-new-screen 'make-frame) - -(provide 'lucid) - -;; Local Variables: -;; byte-compile-warnings: (not cl-functions) -;; End: - -;;; lucid.el ends here diff --git a/lisp/mail/metamail.el b/lisp/obsolete/metamail.el index 0e407ea060e..d6ab4a3d0cf 100644 --- a/lisp/mail/metamail.el +++ b/lisp/obsolete/metamail.el @@ -4,6 +4,7 @@ ;; Author: Masanobu UMEDA <umerin@mse.kyutech.ac.jp> ;; Keywords: mail, news, mime, multimedia +;; Obsolete-since: 28.1 ;; This file is part of GNU Emacs. diff --git a/lisp/obsolete/old-whitespace.el b/lisp/obsolete/old-whitespace.el deleted file mode 100644 index 95010c00200..00000000000 --- a/lisp/obsolete/old-whitespace.el +++ /dev/null @@ -1,801 +0,0 @@ -;;; whitespace.el --- warn about and clean bogus whitespaces in the file - -;; Copyright (C) 1999-2020 Free Software Foundation, Inc. - -;; Author: Rajesh Vaidheeswarran <rv@gnu.org> -;; Keywords: convenience -;; Obsolete-since: 23.1 - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: - -;; URL: http://www.dsmit.com/lisp/ -;; -;; The whitespace library is intended to find and help fix five different types -;; of whitespace problems that commonly exist in source code. -;; -;; 1. Leading space (empty lines at the top of a file). -;; 2. Trailing space (empty lines at the end of a file). -;; 3. Indentation space (8 or more spaces at beginning of line, that should be -;; replaced with TABS). -;; 4. Spaces followed by a TAB. (Almost always, we never want that). -;; 5. Spaces or TABS at the end of a line. -;; -;; Whitespace errors are reported in a buffer, and on the mode line. -;; -;; Mode line will show a W:<x>!<y> to denote a particular type of whitespace, -;; where `x' and `y' can be one (or more) of: -;; -;; e - End-of-Line whitespace. -;; i - Indentation whitespace. -;; l - Leading whitespace. -;; s - Space followed by Tab. -;; t - Trailing whitespace. -;; -;; If any of the whitespace checks is turned off, the mode line will display a -;; !<y>. -;; -;; (since (3) is the most controversial one, here is the rationale: Most -;; terminal drivers and printer drivers have TAB configured or even -;; hardcoded to be 8 spaces. (Some of them allow configuration, but almost -;; always they default to 8.) -;; -;; Changing `tab-width' to other than 8 and editing will cause your code to -;; look different from within Emacs, and say, if you cat it or more it, or -;; even print it. -;; -;; Almost all the popular programming modes let you define an offset (like -;; c-basic-offset or perl-indent-level) to configure the offset, so you -;; should never have to set your `tab-width' to be other than 8 in all -;; these modes. In fact, with an indent level of say, 4, 2 TABS will cause -;; Emacs to replace your 8 spaces with one \t (try it). If vi users in -;; your office complain, tell them to use vim, which distinguishes between -;; tabstop and shiftwidth (vi equivalent of our offsets), and also ask them -;; to set smarttab.) -;; -;; All the above have caused (and will cause) unwanted codeline integration and -;; merge problems. -;; -;; whitespace.el will complain if it detects whitespaces on opening a file, and -;; warn you on closing a file also (in case you had inserted any -;; whitespaces during the process of your editing). -;; -;; Exported functions: -;; -;; `whitespace-buffer' - To check the current buffer for whitespace problems. -;; `whitespace-cleanup' - To cleanup all whitespaces in the current buffer. -;; `whitespace-region' - To check between point and mark for whitespace -;; problems. -;; `whitespace-cleanup-region' - To cleanup all whitespaces between point -;; and mark in the current buffer. - -;;; Code: - -(defvar whitespace-version "3.5" "Version of the whitespace library.") - -(defvar whitespace-all-buffer-files nil - "An associated list of buffers and files checked for whitespace cleanliness. - -This is to enable periodic checking of whitespace cleanliness in the files -visited by the buffers.") - -(defvar whitespace-rescan-timer nil - "Timer object used to rescan the files in buffers that have been modified.") - -;; Tell Emacs about this new kind of minor mode -(defvar whitespace-mode nil - "Non-nil when Whitespace mode (a minor mode) is enabled.") -(make-variable-buffer-local 'whitespace-mode) - -(defvar whitespace-mode-line nil - "String to display in the mode line for Whitespace mode.") -(make-variable-buffer-local 'whitespace-mode-line) - -(defvar whitespace-check-buffer-leading nil - "Test leading whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-leading) -;;;###autoload(put 'whitespace-check-buffer-leading 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-trailing nil - "Test trailing whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-trailing) -;;;###autoload(put 'whitespace-check-buffer-trailing 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-indent nil - "Test indentation whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-indent) -;;;###autoload(put 'whitespace-check-buffer-indent 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-spacetab nil - "Test Space-followed-by-TABS whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-spacetab) -;;;###autoload(put 'whitespace-check-buffer-spacetab 'safe-local-variable 'booleanp) - -(defvar whitespace-check-buffer-ateol nil - "Test end-of-line whitespace for file in current buffer if t.") -(make-variable-buffer-local 'whitespace-check-buffer-ateol) -;;;###autoload(put 'whitespace-check-buffer-ateol 'safe-local-variable 'booleanp) - -(defvar whitespace-highlighted-space nil - "The variable to store the extent to highlight.") -(make-variable-buffer-local 'whitespace-highlighted-space) - -(defalias 'whitespace-make-overlay - (if (featurep 'xemacs) 'make-extent 'make-overlay)) -(defalias 'whitespace-overlay-put - (if (featurep 'xemacs) 'set-extent-property 'overlay-put)) -(defalias 'whitespace-delete-overlay - (if (featurep 'xemacs) 'delete-extent 'delete-overlay)) -(defalias 'whitespace-overlay-start - (if (featurep 'xemacs) 'extent-start 'overlay-start)) -(defalias 'whitespace-overlay-end - (if (featurep 'xemacs) 'extent-end 'overlay-end)) -(defalias 'whitespace-mode-line-update - (if (featurep 'xemacs) 'redraw-modeline 'force-mode-line-update)) - -(defgroup whitespace nil - "Check for and fix five different types of whitespaces in source code." - :version "21.1" - :link '(emacs-commentary-link "whitespace.el") - ;; Since XEmacs doesn't have a 'convenience group, use the next best group - ;; which is 'editing? - :group (if (featurep 'xemacs) 'editing 'convenience)) - -(defcustom whitespace-check-leading-whitespace t - "Flag to check leading whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-leading'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-check-trailing-whitespace t - "Flag to check trailing whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-trailing'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-check-spacetab-whitespace t - "Flag to check space followed by a TAB. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-spacetab'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-spacetab-regexp "[ ]+\t" - "Regexp to match one or more spaces followed by a TAB." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-check-indent-whitespace indent-tabs-mode - "Flag to check indentation whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-indent'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-indent-regexp "^\t*\\( \\)+" - "Regexp to match multiples of eight spaces near line beginnings. -The default value ignores leading TABs." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-check-ateol-whitespace t - "Flag to check end-of-line whitespace. This is the global for the system. -It can be overridden by setting a buffer local variable -`whitespace-check-buffer-ateol'." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-ateol-regexp "[ \t]+$" - "Regexp to match one or more TABs or spaces at line ends." - :type 'regexp - :group 'whitespace) - -(defcustom whitespace-errbuf "*Whitespace Errors*" - "The name of the buffer where whitespace related messages will be logged." - :type 'string - :group 'whitespace) - -(defcustom whitespace-clean-msg "clean." - "If non-nil, this message will be displayed after a whitespace check -determines a file to be clean." - :type 'string - :group 'whitespace) - -(defcustom whitespace-abort-on-error nil - "While writing a file, abort if the file is unclean. -If `whitespace-auto-cleanup' is set, that takes precedence over -this variable." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-auto-cleanup nil - "Cleanup a buffer automatically on finding it whitespace unclean." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-silent nil - "All whitespace errors will be shown only in the mode line when t. - -Note that setting this may cause all whitespaces introduced in a file to go -unnoticed when the buffer is killed, unless the user visits the `*Whitespace -Errors*' buffer before opening (or closing) another file." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-modes '(ada-mode asm-mode autoconf-mode awk-mode - c-mode c++-mode cc-mode - change-log-mode cperl-mode - electric-nroff-mode emacs-lisp-mode - f90-mode fortran-mode html-mode - html3-mode java-mode jde-mode - ksh-mode latex-mode LaTeX-mode - lisp-mode m4-mode makefile-mode - modula-2-mode nroff-mode objc-mode - pascal-mode perl-mode prolog-mode - python-mode scheme-mode sgml-mode - sh-mode shell-script-mode simula-mode - tcl-mode tex-mode texinfo-mode - vrml-mode xml-mode) - - "Major modes in which we turn on whitespace checking. - -These are mostly programming and documentation modes. But you may add other -modes that you want whitespaces checked in by adding something like the -following to your `.emacs': - -\(setq whitespace-modes (cons \\='my-mode (cons \\='my-other-mode - whitespace-modes))\) - -Or, alternately, you can use the Emacs `customize' command to set this." - :type '(repeat symbol) - :group 'whitespace) - -(defcustom whitespace-rescan-timer-time 600 - "Period in seconds to rescan modified buffers for whitespace creep. - -This is the period after which the timer will fire causing -`whitespace-rescan-files-in-buffers' to check for whitespace creep in -modified buffers. - -To disable timer scans, set this to zero." - :type 'integer - :group 'whitespace) - -(defcustom whitespace-display-in-modeline t - "Display whitespace errors on the modeline." - :type 'boolean - :group 'whitespace) - -(defcustom whitespace-display-spaces-in-color t - "Display the bogus whitespaces by coloring them with the face -`whitespace-highlight'." - :type 'boolean - :group 'whitespace) - -(defface whitespace-highlight '((((class color) (background light)) - (:background "green1")) - (((class color) (background dark)) - (:background "sea green")) - (((class grayscale mono) - (background light)) - (:background "black")) - (((class grayscale mono) - (background dark)) - (:background "white"))) - "Face used for highlighting the bogus whitespaces that exist in the buffer." - :group 'whitespace) - -(if (not (assoc 'whitespace-mode minor-mode-alist)) - (setq minor-mode-alist (cons '(whitespace-mode whitespace-mode-line) - minor-mode-alist))) - -(set-default 'whitespace-check-buffer-leading - whitespace-check-leading-whitespace) -(set-default 'whitespace-check-buffer-trailing - whitespace-check-trailing-whitespace) -(set-default 'whitespace-check-buffer-indent - whitespace-check-indent-whitespace) -(set-default 'whitespace-check-buffer-spacetab - whitespace-check-spacetab-whitespace) -(set-default 'whitespace-check-buffer-ateol - whitespace-check-ateol-whitespace) - -(defun whitespace-check-whitespace-mode (&optional arg) - "Test and set the whitespace-mode in qualifying buffers." - (if (null whitespace-mode) - (setq whitespace-mode - (if (or arg (member major-mode whitespace-modes)) - t - nil)))) - -;;;###autoload -(defun whitespace-toggle-leading-check () - "Toggle the check for leading space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-leading)) - (setq whitespace-check-buffer-leading (not current-val)) - (message "Will%s check for leading space in buffer." - (if whitespace-check-buffer-leading "" " not")) - (if whitespace-check-buffer-leading (whitespace-buffer-leading)))) - -;;;###autoload -(defun whitespace-toggle-trailing-check () - "Toggle the check for trailing space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-trailing)) - (setq whitespace-check-buffer-trailing (not current-val)) - (message "Will%s check for trailing space in buffer." - (if whitespace-check-buffer-trailing "" " not")) - (if whitespace-check-buffer-trailing (whitespace-buffer-trailing)))) - -;;;###autoload -(defun whitespace-toggle-indent-check () - "Toggle the check for indentation space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-indent)) - (setq whitespace-check-buffer-indent (not current-val)) - (message "Will%s check for indentation space in buffer." - (if whitespace-check-buffer-indent "" " not")) - (if whitespace-check-buffer-indent - (whitespace-buffer-search whitespace-indent-regexp)))) - -;;;###autoload -(defun whitespace-toggle-spacetab-check () - "Toggle the check for space-followed-by-TABs in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-spacetab)) - (setq whitespace-check-buffer-spacetab (not current-val)) - (message "Will%s check for space-followed-by-TABs in buffer." - (if whitespace-check-buffer-spacetab "" " not")) - (if whitespace-check-buffer-spacetab - (whitespace-buffer-search whitespace-spacetab-regexp)))) - - -;;;###autoload -(defun whitespace-toggle-ateol-check () - "Toggle the check for end-of-line space in the local buffer." - (interactive) - (let ((current-val whitespace-check-buffer-ateol)) - (setq whitespace-check-buffer-ateol (not current-val)) - (message "Will%s check for end-of-line space in buffer." - (if whitespace-check-buffer-ateol "" " not")) - (if whitespace-check-buffer-ateol - (whitespace-buffer-search whitespace-ateol-regexp)))) - - -;;;###autoload -(defun whitespace-buffer (&optional quiet) - "Find five different types of white spaces in buffer. -These are: -1. Leading space \(empty lines at the top of a file\). -2. Trailing space \(empty lines at the end of a file\). -3. Indentation space \(8 or more spaces, that should be replaced with TABS\). -4. Spaces followed by a TAB. \(Almost always, we never want that\). -5. Spaces or TABS at the end of a line. - -Check for whitespace only if this buffer really contains a non-empty file -and: -1. the major mode is one of the whitespace-modes, or -2. `whitespace-buffer' was explicitly called with a prefix argument." - (interactive) - (let ((whitespace-error nil)) - (whitespace-check-whitespace-mode current-prefix-arg) - (if (and buffer-file-name (> (buffer-size) 0) whitespace-mode) - (progn - (whitespace-check-buffer-list (buffer-name) buffer-file-name) - (whitespace-tickle-timer) - (overlay-recenter (point-max)) - (remove-overlays nil nil 'face 'whitespace-highlight) - (if whitespace-auto-cleanup - (if buffer-read-only - (if (not quiet) - (message "Can't cleanup: %s is read-only" (buffer-name))) - (whitespace-cleanup-internal)) - (let ((whitespace-leading (if whitespace-check-buffer-leading - (whitespace-buffer-leading) - nil)) - (whitespace-trailing (if whitespace-check-buffer-trailing - (whitespace-buffer-trailing) - nil)) - (whitespace-indent (if whitespace-check-buffer-indent - (whitespace-buffer-search - whitespace-indent-regexp) - nil)) - (whitespace-spacetab (if whitespace-check-buffer-spacetab - (whitespace-buffer-search - whitespace-spacetab-regexp) - nil)) - (whitespace-ateol (if whitespace-check-buffer-ateol - (whitespace-buffer-search - whitespace-ateol-regexp) - nil)) - (whitespace-errmsg nil) - (whitespace-filename buffer-file-name) - (whitespace-this-modeline "")) - - ;; Now let's complain if we found any of the above. - (setq whitespace-error (or whitespace-leading whitespace-indent - whitespace-spacetab whitespace-ateol - whitespace-trailing)) - - (if whitespace-error - (progn - (setq whitespace-errmsg - (concat whitespace-filename " contains:\n" - (if whitespace-leading - "Leading whitespace\n") - (if whitespace-indent - (concat "Indentation whitespace" - whitespace-indent "\n")) - (if whitespace-spacetab - (concat "Space followed by Tab" - whitespace-spacetab "\n")) - (if whitespace-ateol - (concat "End-of-line whitespace" - whitespace-ateol "\n")) - (if whitespace-trailing - "Trailing whitespace\n") - "\ntype `M-x whitespace-cleanup' to " - "cleanup the file.")) - (setq whitespace-this-modeline - (concat (if whitespace-ateol "e") - (if whitespace-indent "i") - (if whitespace-leading "l") - (if whitespace-spacetab "s") - (if whitespace-trailing "t"))))) - (whitespace-update-modeline whitespace-this-modeline) - (if (get-buffer whitespace-errbuf) - (kill-buffer whitespace-errbuf)) - (with-current-buffer (get-buffer-create whitespace-errbuf) - (if whitespace-errmsg - (progn - (insert whitespace-errmsg) - (if (not (or quiet whitespace-silent)) - (display-buffer (current-buffer) t)) - (if (not quiet) - (message "Whitespaces: [%s%s] in %s" - whitespace-this-modeline - (let ((whitespace-unchecked - (whitespace-unchecked-whitespaces))) - (if whitespace-unchecked - (concat "!" whitespace-unchecked) - "")) - whitespace-filename))) - (if (and (not quiet) (not (equal whitespace-clean-msg ""))) - (message "%s %s" whitespace-filename - whitespace-clean-msg)))))))) - whitespace-error)) - -;;;###autoload -(defun whitespace-region (s e) - "Check the region for whitespace errors." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region s e) - (whitespace-buffer)))) - -;;;###autoload -(defun whitespace-cleanup () - "Cleanup the five different kinds of whitespace problems. -It normally applies to the whole buffer, but in Transient Mark mode -when the mark is active it applies to the region. -See `whitespace-buffer' docstring for a summary of the problems." - (interactive) - (if (and transient-mark-mode mark-active) - (whitespace-cleanup-region (region-beginning) (region-end)) - (whitespace-cleanup-internal))) - -(defun whitespace-cleanup-internal (&optional region-only) - ;; If this buffer really contains a file, then run, else quit. - (whitespace-check-whitespace-mode current-prefix-arg) - (if (and buffer-file-name whitespace-mode) - (let ((whitespace-any nil) - (whitespace-tabwidth 8) - (whitespace-tabwidth-saved tab-width)) - - ;; since all printable TABS should be 8, irrespective of how - ;; they are displayed. - (setq tab-width whitespace-tabwidth) - - (if (and whitespace-check-buffer-leading - (whitespace-buffer-leading)) - (progn - (whitespace-buffer-leading-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-trailing - (whitespace-buffer-trailing)) - (progn - (whitespace-buffer-trailing-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-indent - (whitespace-buffer-search whitespace-indent-regexp)) - (progn - (whitespace-indent-cleanup) - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-spacetab - (whitespace-buffer-search whitespace-spacetab-regexp)) - (progn - (whitespace-buffer-cleanup whitespace-spacetab-regexp "\t") - (setq whitespace-any t))) - - (if (and whitespace-check-buffer-ateol - (whitespace-buffer-search whitespace-ateol-regexp)) - (progn - (whitespace-buffer-cleanup whitespace-ateol-regexp "") - (setq whitespace-any t))) - - ;; Call this recursively till everything is taken care of - (if whitespace-any - (whitespace-cleanup-internal region-only) - ;; if we are done, talk to the user - (progn - (unless whitespace-silent - (if region-only - (message "The region is now clean") - (message "%s is now clean" buffer-file-name))) - (whitespace-update-modeline))) - (setq tab-width whitespace-tabwidth-saved)))) - -;;;###autoload -(defun whitespace-cleanup-region (s e) - "Whitespace cleanup on the region." - (interactive "r") - (save-excursion - (save-restriction - (narrow-to-region s e) - (whitespace-cleanup-internal t)) - (whitespace-buffer t))) - -(defun whitespace-buffer-leading () - "Return t if the current buffer has leading newline characters. -If highlighting is enabled, highlight these characters." - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n") - (unless (bobp) - (whitespace-highlight-the-space (point-min) (point)) - t))) - -(defun whitespace-buffer-leading-cleanup () - "Remove any leading newline characters from current buffer." - (save-excursion - (goto-char (point-min)) - (skip-chars-forward "\n") - (delete-region (point-min) (point)))) - -(defun whitespace-buffer-trailing () - "Return t if the current buffer has extra trailing newline characters. -If highlighting is enabled, highlight these characters." - (save-excursion - (goto-char (point-max)) - (skip-chars-backward "\n") - (forward-line) - (unless (eobp) - (whitespace-highlight-the-space (point) (point-max)) - t))) - -(defun whitespace-buffer-trailing-cleanup () - "Remove extra trailing newline characters from current buffer." - (save-excursion - (goto-char (point-max)) - (skip-chars-backward "\n") - (unless (eobp) - (forward-line) - (delete-region (point) (point-max))))) - -(defun whitespace-buffer-search (regexp) - "Search for any given whitespace REGEXP." - (with-local-quit - (let (whitespace-retval) - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (whitespace-highlight-the-space (match-beginning 0) (match-end 0)) - (push (match-beginning 0) whitespace-retval))) - (when whitespace-retval - (format " %s" (nreverse whitespace-retval)))))) - -(defun whitespace-buffer-cleanup (regexp newregexp) - "Search for any given whitespace REGEXP and replace it with the NEWREGEXP." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward regexp nil t) - (replace-match newregexp)))) - -(defun whitespace-indent-cleanup () - "Search for 8/more spaces at the start of a line and replace it with tabs." - (save-excursion - (goto-char (point-min)) - (while (re-search-forward whitespace-indent-regexp nil t) - (let ((column (current-column)) - (indent-tabs-mode t)) - (delete-region (match-beginning 0) (point)) - (indent-to column))))) - -(defun whitespace-unchecked-whitespaces () - "Return the list of whitespaces whose testing has been suppressed." - (let ((unchecked-spaces - (concat (if (not whitespace-check-buffer-ateol) "e") - (if (not whitespace-check-buffer-indent) "i") - (if (not whitespace-check-buffer-leading) "l") - (if (not whitespace-check-buffer-spacetab) "s") - (if (not whitespace-check-buffer-trailing) "t")))) - (if (not (equal unchecked-spaces "")) - unchecked-spaces - nil))) - -(defun whitespace-update-modeline (&optional whitespace-err) - "Update mode line with whitespace errors. -Also with whitespaces whose testing has been turned off." - (if whitespace-display-in-modeline - (progn - (setq whitespace-mode-line nil) - ;; Whitespace errors - (if (and whitespace-err (not (equal whitespace-err ""))) - (setq whitespace-mode-line whitespace-err)) - ;; Whitespace suppressed errors - (let ((whitespace-unchecked (whitespace-unchecked-whitespaces))) - (if whitespace-unchecked - (setq whitespace-mode-line - (concat whitespace-mode-line "!" whitespace-unchecked)))) - ;; Add the whitespace modeline prefix - (setq whitespace-mode-line (if whitespace-mode-line - (concat " W:" whitespace-mode-line) - nil)) - (whitespace-mode-line-update)))) - -(defun whitespace-highlight-the-space (b e) - "Highlight the current line, unhighlighting a previously jumped to line." - (if whitespace-display-spaces-in-color - (let ((ol (whitespace-make-overlay b e))) - (whitespace-overlay-put ol 'face 'whitespace-highlight)))) - -(defun whitespace-unhighlight-the-space() - "Unhighlight the currently highlight line." - (if (and whitespace-display-spaces-in-color whitespace-highlighted-space) - (progn - (mapc 'whitespace-delete-overlay whitespace-highlighted-space) - (setq whitespace-highlighted-space nil)))) - -(defun whitespace-check-buffer-list (buf-name buf-file) - "Add a buffer and its file to the whitespace monitor list. - -The buffer named BUF-NAME and its associated file BUF-FILE are now monitored -periodically for whitespace." - (if (and whitespace-mode (not (member (list buf-file buf-name) - whitespace-all-buffer-files))) - (add-to-list 'whitespace-all-buffer-files (list buf-file buf-name)))) - -(defun whitespace-tickle-timer () - "Tickle timer to periodically to scan qualifying files for whitespace creep. - -If timer is not set, then set it to scan the files in -`whitespace-all-buffer-files' periodically (defined by -`whitespace-rescan-timer-time') for whitespace creep." - (if (and whitespace-rescan-timer-time - (/= whitespace-rescan-timer-time 0) - (not whitespace-rescan-timer)) - (setq whitespace-rescan-timer - (add-timeout whitespace-rescan-timer-time - 'whitespace-rescan-files-in-buffers nil - whitespace-rescan-timer-time)))) - -(defun whitespace-rescan-files-in-buffers (&optional arg) - "Check monitored files for whitespace creep since last scan." - (let ((whitespace-all-my-files whitespace-all-buffer-files) - buffile bufname thiselt buf) - (if (not whitespace-all-my-files) - (progn - (disable-timeout whitespace-rescan-timer) - (setq whitespace-rescan-timer nil)) - (while whitespace-all-my-files - (setq thiselt (car whitespace-all-my-files)) - (setq whitespace-all-my-files (cdr whitespace-all-my-files)) - (setq buffile (car thiselt)) - (setq bufname (cadr thiselt)) - (setq buf (get-buffer bufname)) - (if (buffer-live-p buf) - (with-current-buffer bufname - ;;(message "buffer %s live" bufname) - (if whitespace-mode - (progn - ;;(message "checking for whitespace in %s" bufname) - (if whitespace-auto-cleanup - (progn - ;;(message "cleaning up whitespace in %s" bufname) - (whitespace-cleanup-internal)) - (progn - ;;(message "whitespace-buffer %s." (buffer-name)) - (whitespace-buffer t)))) - ;;(message "Removing %s from refresh list" bufname) - (whitespace-refresh-rescan-list buffile bufname))) - ;;(message "Removing %s from refresh list" bufname) - (whitespace-refresh-rescan-list buffile bufname)))))) - -(defun whitespace-refresh-rescan-list (buffile bufname) - "Refresh the list of files to be rescanned for whitespace creep." - (if whitespace-all-buffer-files - (setq whitespace-all-buffer-files - (delete (list buffile bufname) whitespace-all-buffer-files)) - (when whitespace-rescan-timer - (disable-timeout whitespace-rescan-timer) - (setq whitespace-rescan-timer nil)))) - -;;;###autoload -(defalias 'global-whitespace-mode 'whitespace-global-mode) - -;;;###autoload -(define-minor-mode whitespace-global-mode - "Toggle using Whitespace mode in new buffers. - -When this mode is active, `whitespace-buffer' is added to -`find-file-hook' and `kill-buffer-hook'." - :global t - :group 'whitespace - (if whitespace-global-mode - (progn - (add-hook 'find-file-hook 'whitespace-buffer) - (add-hook 'write-file-functions 'whitespace-write-file-hook nil t) - (add-hook 'kill-buffer-hook 'whitespace-buffer)) - (remove-hook 'find-file-hook 'whitespace-buffer) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t) - (remove-hook 'kill-buffer-hook 'whitespace-buffer))) - -;;;###autoload -(defun whitespace-write-file-hook () - "Hook function to be called on the buffer when whitespace check is enabled. -This is meant to be added buffer-locally to `write-file-functions'." - (let ((werr nil)) - (if whitespace-auto-cleanup - (whitespace-cleanup-internal) - (setq werr (whitespace-buffer))) - (if (and whitespace-abort-on-error werr) - (error "Abort write due to whitespaces in %s" - buffer-file-name))) - nil) - -(defun whitespace-unload-function () - "Unload the whitespace library." - (if (unintern "whitespace-unload-hook" obarray) - ;; if whitespace-unload-hook is defined, let's get rid of it - ;; and recursively call `unload-feature' - (progn (unload-feature 'whitespace) t) - ;; this only happens in the recursive call - (whitespace-global-mode -1) - (save-current-buffer - (dolist (buf (buffer-list)) - (set-buffer buf) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t))) - ;; continue standard unloading - nil)) - -(defun whitespace-unload-hook () - (remove-hook 'find-file-hook 'whitespace-buffer) - (remove-hook 'write-file-functions 'whitespace-write-file-hook t) - (remove-hook 'kill-buffer-hook 'whitespace-buffer)) - -(add-hook 'whitespace-unload-hook 'whitespace-unload-hook) - -(provide 'whitespace) - -;;; whitespace.el ends here diff --git a/lisp/obsolete/rcompile.el b/lisp/obsolete/rcompile.el index 5ef8be20d98..6d95b7136b1 100644 --- a/lisp/obsolete/rcompile.el +++ b/lisp/obsolete/rcompile.el @@ -89,7 +89,7 @@ nil means use the value returned by \\[user-login-name]." "Command to run before compilation. This can be used for setting up environment variables, since rsh does not invoke the shell as a login shell and files like .login -\(tcsh\) and .bash_profile \(bash\) are not run. +\(tcsh) and .bash_profile \(bash) are not run. nil means run no commands." :type '(choice string (const nil)) :group 'remote-compile) diff --git a/lisp/obsolete/sb-image.el b/lisp/obsolete/sb-image.el new file mode 100644 index 00000000000..fd8884738d4 --- /dev/null +++ b/lisp/obsolete/sb-image.el @@ -0,0 +1,46 @@ +;;; sb-image --- Image management for speedbar + +;; Copyright (C) 1999-2003, 2005-2019 Free Software Foundation, Inc. + +;; Author: Eric M. Ludlam <zappo@gnu.org> +;; Keywords: file, tags, tools +;; Obsolete-since: 28.1 + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; This file is obsolete. +;; +;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs, +;; is a challenging task, which doesn't take kindly to being byte compiled. +;; When sharing speedbar.elc between these three applications, the Image +;; support can get lost. +;; +;; By splitting out that hard part into this file, and avoiding byte +;; compilation, one copy speedbar can support all these platforms together. +;; +;; This file requires the `image' package if it is available. + +(require 'ezimage) + +;;; Code: + +(defalias 'defimage-speedbar 'defezimage) + +(provide 'sb-image) + +;;; sb-image.el ends here diff --git a/lisp/obsolete/tls.el b/lisp/obsolete/tls.el index cd091c0108e..d1b215cbfb8 100644 --- a/lisp/obsolete/tls.el +++ b/lisp/obsolete/tls.el @@ -47,9 +47,6 @@ (require 'gnutls) -(autoload 'format-spec "format-spec") -(autoload 'format-spec-make "format-spec") - (defgroup tls nil "Transport Layer Security (TLS) parameters." :group 'comm) @@ -224,14 +221,11 @@ Fourth arg PORT is an integer specifying a port to connect to." (while (and (not done) (setq cmd (pop cmds))) (let ((process-connection-type tls-process-connection-type) (formatted-cmd - (format-spec - cmd - (format-spec-make - ?t (car (gnutls-trustfiles)) - ?h host - ?p (if (integerp port) - (int-to-string port) - port))))) + (format-spec cmd `((?t . ,(car (gnutls-trustfiles))) + (?h . ,host) + (?p . ,(if (integerp port) + (number-to-string port) + port)))))) (message "Opening TLS connection with `%s'..." formatted-cmd) (setq process (start-process name buffer shell-file-name shell-command-switch diff --git a/lisp/obsolete/vc-arch.el b/lisp/obsolete/vc-arch.el index bcdefac5187..93bd991eb3a 100644 --- a/lisp/obsolete/vc-arch.el +++ b/lisp/obsolete/vc-arch.el @@ -597,20 +597,21 @@ CALLBACK expects (ENTRIES &optional MORE-TO-COME); see (unless (file-writable-p rl-dir) (error "No writable revlib directory found")) (message "Revlib at %s" rl-dir) - (let* ((archives (directory-files rl-dir 'full (rx (or (not ".") "...")))) + (let* ((archives (directory-files rl-dir 'full + directory-files-no-dot-files-regexp)) (categories (apply 'append (mapcar (lambda (dir) (when (file-directory-p dir) - (directory-files dir 'full - (rx (or (not ".") "..."))))) + (directory-files + dir 'full directory-files-no-dot-files-regexp))) archives))) (branches (apply 'append (mapcar (lambda (dir) (when (file-directory-p dir) - (directory-files dir 'full - (rx (or (not ".") "..."))))) + (directory-files + dir 'full directory-files-no-dot-files-regexp))) categories))) (versions (apply 'append diff --git a/lisp/obsolete/vi.el b/lisp/obsolete/vi.el index df5ddfdbcf9..eee00b43a26 100644 --- a/lisp/obsolete/vi.el +++ b/lisp/obsolete/vi.el @@ -1225,7 +1225,7 @@ SPECIAL FEATURE: char argument can be used to specify shift amount(1-9)." (defun vi-end-of-blank-delimited-word (count) "Forward to the end of the COUNT'th blank-delimited word." (interactive "p") - (if (re-search-forward "[^ \t\n\']+[ \t\n\']" nil t count) + (if (re-search-forward "[^ \t\n']+[ \t\n']" nil t count) (if (not (eobp)) (backward-char 2)))) (defun vi-home-window-line (arg) diff --git a/lisp/obsolete/vip.el b/lisp/obsolete/vip.el index 4a9b8fff264..37defd1c5a4 100644 --- a/lisp/obsolete/vip.el +++ b/lisp/obsolete/vip.el @@ -80,7 +80,7 @@ (defvar vip-current-major-mode nil "vip-current-major-mode is the major-mode vi considers it is now. -\(buffer specific\)") +\(buffer specific)") (make-variable-buffer-local 'vip-current-major-mode) @@ -1510,7 +1510,7 @@ used. This behavior is controlled by the sign of prefix numeric value." (* (/ (point-max) 100) arg) (/ (* (point-max) arg) 100))) (back-to-indentation)) - (cond ((looking-at "[\(\[{]") + (cond ((looking-at "[([{]") (if com (move-marker vip-com-point (point))) (forward-sexp 1) (if com @@ -1719,7 +1719,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer) (setq buffer (read-buffer - (format "switch to buffer \(%s\): " + (format "switch to buffer (%s): " (buffer-name (other-buffer (current-buffer)))))) (switch-to-buffer buffer) (vip-change-mode-to-vi))) @@ -1730,7 +1730,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer) (setq buffer (read-buffer - (format "Switch to buffer \(%s\): " + (format "Switch to buffer (%s): " (buffer-name (other-buffer (current-buffer)))))) (switch-to-buffer-other-window buffer) (vip-change-mode-to-vi))) @@ -1741,7 +1741,7 @@ STRING. Search will be forward if FORWARD, otherwise backward." (let (buffer buffer-name) (setq buffer-name (read-buffer - (format "Kill buffer \(%s\): " + (format "Kill buffer (%s): " (buffer-name (current-buffer))))) (setq buffer (if (null buffer-name) @@ -2162,7 +2162,7 @@ is a command.") (defun vip-get-ex-token () "get an ex-token which is either an address or a command. -a token has type \(command, address, end-mark\) and value." +a token has type \(command, address, end-mark) and value." (with-current-buffer " *ex-working-space*" (skip-chars-forward " \t") (cond ((looking-at "[k#]") @@ -2668,7 +2668,7 @@ a token has type \(command, address, end-mark\) and value." "ex-edit" (vip-get-ex-file) (if (and (not ex-variant) (buffer-modified-p) buffer-file-name) - (error "No write since last change \(:e! overrides\)")) + (error "No write since last change (:e! overrides)")) (vip-change-mode-to-emacs) (set-buffer (find-file-noselect (concat default-directory ex-file))) diff --git a/lisp/org/ob-core.el b/lisp/org/ob-core.el index 7654c7ebe41..fe9af1ce602 100644 --- a/lisp/org/ob-core.el +++ b/lisp/org/ob-core.el @@ -2437,7 +2437,7 @@ INFO may provide the values of these header arguments (in the (when location (save-excursion (goto-char location) - (when (looking-at (concat org-babel-result-regexp ".*$")) + (when (looking-at org-babel-result-regexp) (delete-region (if keep-keyword (line-beginning-position 2) (save-excursion @@ -3053,9 +3053,8 @@ of `org-babel-temporary-directory'." (if (eq t (car (file-attributes file))) (delete-directory file) (delete-file file))) - ;; We do not want to delete "." and "..". (directory-files org-babel-temporary-directory 'full - (rx (or (not ".") "...")))) + directory-files-no-dot-files-regexp)) (delete-directory org-babel-temporary-directory)) (error (message "Failed to remove temporary Org-babel directory %s" diff --git a/lisp/org/ob-fortran.el b/lisp/org/ob-fortran.el index 154465f28e1..149058f05f4 100644 --- a/lisp/org/ob-fortran.el +++ b/lisp/org/ob-fortran.el @@ -106,7 +106,7 @@ its header arguments." (defun org-babel-fortran-ensure-main-wrap (body params) "Wrap body in a \"program ... end program\" block if none exists." - (if (string-match "^[ \t]*program[ \t]*.*" (capitalize body)) + (if (string-match "^[ \t]*program\\>" (capitalize body)) (let ((vars (org-babel--get-vars params))) (when vars (error "Cannot use :vars if `program' statement is present")) body) diff --git a/lisp/org/ob-screen.el b/lisp/org/ob-screen.el index ad00ee070d4..837c18f8407 100644 --- a/lisp/org/ob-screen.el +++ b/lisp/org/ob-screen.el @@ -126,7 +126,7 @@ The terminal should shortly flicker." ;; XXX: need to find a better way to do the following (while (not (file-readable-p tmpfile)) ;; do something, otherwise this will be optimized away - (format "org-babel-screen: File not readable yet.")) + (sit-for 0.1)) (setq tmp-string (with-temp-buffer (insert-file-contents-literally tmpfile) (buffer-substring (point-min) (point-max)))) diff --git a/lisp/org/ol.el b/lisp/org/ol.el index baed23bc9a4..c9e4da598ff 100644 --- a/lisp/org/ol.el +++ b/lisp/org/ol.el @@ -845,8 +845,8 @@ E.g. \"%C3%B6\" becomes the german o-Umlaut." (insert link) (insert (make-string (- (skip-chars-backward "\\\\")) ?\\)) - (while (search-backward "\]" nil t) - (when (looking-at-p "\\]\\(?:[][]\\|\\'\\)") + (while (search-backward "]" nil t) + (when (looking-at-p "]\\(?:[][]\\|\\'\\)") (insert (make-string (1+ (- (skip-chars-backward "\\\\"))) ?\\)))) (buffer-string))) diff --git a/lisp/org/org-agenda.el b/lisp/org/org-agenda.el index 4f89ea54500..689d134627e 100644 --- a/lisp/org/org-agenda.el +++ b/lisp/org/org-agenda.el @@ -1883,7 +1883,7 @@ Nil means don't hide any tags." :group 'org-agenda-line-format :type '(choice (const :tag "Hide none" nil) - (string :tag "Regexp "))) + (regexp :tag "Regexp "))) (defvaralias 'org-agenda-remove-tags-when-in-prefix 'org-agenda-remove-tags) @@ -1980,7 +1980,7 @@ category, you can use: (\"Emacs\" \\='(space . (:width (16))))" :group 'org-agenda-line-format :version "24.1" - :type '(alist :key-type (string :tag "Regexp matching category") + :type '(alist :key-type (regexp :tag "Regexp matching category") :value-type (choice (list :tag "Icon" (string :tag "File or data") (symbol :tag "Type") @@ -2995,7 +2995,8 @@ Agenda views are separated by `org-agenda-block-separator'." (erase-buffer) (insert (eval-when-compile (let ((header - "Press key for an agenda command: + (copy-sequence + "Press key for an agenda command: -------------------------------- < Buffer, subtree/region restriction a Agenda for current week or day > Remove restriction t List of all TODO entries e Export agenda views @@ -3004,7 +3005,7 @@ s Search for keywords M Like m, but only TODO entries / Multi-occur S Like s, but only TODO entries ? Find :FLAGGED: entries C Configure custom agenda commands * Toggle sticky agenda views # List stuck projects (!=configure) -") +")) (start 0)) (while (string-match "\\(^\\| \\|(\\)\\(\\S-\\)\\( \\|=\\)" @@ -8981,7 +8982,6 @@ fold drawers." (narrow-to-region (org-entry-beginning-position) (org-entry-end-position)) (org-show-all '(drawers)))) - (when arg ) (setq org-agenda-show-window (selected-window))) (select-window win))) diff --git a/lisp/org/org-capture.el b/lisp/org/org-capture.el index 003cbef1fdf..ace51270175 100644 --- a/lisp/org/org-capture.el +++ b/lisp/org/org-capture.el @@ -1021,7 +1021,7 @@ Store them in the capture property list." (apply #'encode-time 0 0 org-extend-today-until (cl-cdddr (decode-time prompt-time)))) - ((string-match "\\([^ ]+\\)--?[^ ]+[ ]+\\(.*\\)" + ((string-match "\\([^ ]+\\)-[^ ]+[ ]+\\(.*\\)" org-read-date-final-answer) ;; Replace any time range by its start. (apply #'encode-time diff --git a/lisp/org/org-element.el b/lisp/org/org-element.el index 4b5f9a19e6d..be74dfdbeff 100644 --- a/lisp/org/org-element.el +++ b/lisp/org/org-element.el @@ -4892,7 +4892,7 @@ with `org-element--cache-compare'. This cache is used in A request is a vector with the following pattern: - \[NEXT BEG END OFFSET PARENT PHASE] + [NEXT BEG END OFFSET PARENT PHASE] Processing a synchronization request consists of three phases: diff --git a/lisp/org/org-protocol.el b/lisp/org/org-protocol.el index 0ff0e401d27..55a534d0dcd 100644 --- a/lisp/org/org-protocol.el +++ b/lisp/org/org-protocol.el @@ -278,7 +278,7 @@ This should be a single regexp string." :group 'org-protocol :version "24.4" :package-version '(Org . "8.0") - :type 'string) + :type 'regexp) ;;; Helper functions: diff --git a/lisp/org/org-table.el b/lisp/org/org-table.el index 49765472558..abba29952e6 100644 --- a/lisp/org/org-table.el +++ b/lisp/org/org-table.el @@ -198,7 +198,7 @@ Other options offered by the customize interface are more restrictive." "^\\([<>]?[-+^.0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") (const :tag "Very General Number-Like, including hex and Calc radix, allows comma as decimal mark" "^\\([<>]?[-+^.,0-9]*[0-9][-+^.0-9eEdDx()%]*\\|[<>]?[-+]?0[xX][[:xdigit:].]+\\|[<>]?[-+]?[0-9]+#[0-9a-zA-Z.]+\\|nan\\|[-+u]?inf\\)$") - (string :tag "Regexp:"))) + (regexp :tag "Regexp:"))) (defcustom org-table-number-fraction 0.5 "Fraction of numbers in a column required to make the column align right. @@ -2005,7 +2005,7 @@ the table and kill the editing buffer." text) (goto-char (point-min)) (while (re-search-forward "^#.*\n?" nil t) (replace-match "")) - (while (re-search-forward "\\([ \t]*\n[ \t]*\\)+" nil t) + (while (re-search-forward "[ \t]*\n[ \t\n]*" nil t) (replace-match " ")) (setq text (org-trim (buffer-string))) (set-window-configuration cw) @@ -3099,7 +3099,7 @@ function assumes the table is already analyzed (i.e., using (let ((lhs (car e)) (rhs (cdr e))) (cond - ((string-match-p "\\`@-?[-+0-9]+\\$-?[0-9]+\\'" lhs) + ((string-match-p "\\`@[-+0-9]+\\$-?[0-9]+\\'" lhs) ;; This just refers to one fixed field. (push e res)) ((string-match-p "\\`[a-zA-Z][_a-zA-Z0-9]*\\'" lhs) diff --git a/lisp/org/org.el b/lisp/org/org.el index 568f5b9b873..f1a7f61a9a1 100644 --- a/lisp/org/org.el +++ b/lisp/org/org.el @@ -460,7 +460,7 @@ Matched keyword is in group 1.") org-clock-string) t) "\\)?" - " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?[]>]" + " *\\([[<][0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*[]>]" "\\|" "<%%([^\r\n>]*>\\)") "Matches a timestamp, possibly preceded by a keyword.") @@ -564,14 +564,14 @@ Effort estimates given in this property need to have the format H:MM.") ;;;; Timestamp -(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)>" +(defconst org-ts-regexp "<\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^\r\n>]*\\)>" "Regular expression for fast time stamp matching.") (defconst org-ts-regexp-inactive - "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^\r\n>]*?\\)\\]" + "\\[\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*\\)\\]" "Regular expression for fast inactive time stamp matching.") -(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\} ?[^]\r\n>]*?\\)[]>]" +(defconst org-ts-regexp-both "[[<]\\([0-9]\\{4\\}-[0-9]\\{2\\}-[0-9]\\{2\\}[^]\r\n>]*\\)[]>]" "Regular expression for fast time stamp matching.") (defconst org-ts-regexp0 @@ -11410,8 +11410,8 @@ D Show deadlines and scheduled items between a date range." (setq type (or type org-sparse-tree-default-date-type)) (setq org-ts-type type) (message "Sparse tree: [r]egexp [t]odo [T]odo-kwd [m]atch [p]roperty - \[d]eadlines [b]efore-date [a]fter-date [D]ates range - \[c]ycle through date types: %s" + [d]eadlines [b]efore-date [a]fter-date [D]ates range + [c]ycle through date types: %s" (cl-case type (all "all timestamps") (scheduled "only scheduled") diff --git a/lisp/org/ox-latex.el b/lisp/org/ox-latex.el index edb3150796f..2f61abad9cc 100644 --- a/lisp/org/ox-latex.el +++ b/lisp/org/ox-latex.el @@ -1239,7 +1239,7 @@ calling `org-latex-compile'." :package-version '(Org . "8.3") :type '(repeat (cons - (string :tag "Regexp") + (regexp :tag "Regexp") (string :tag "Message")))) diff --git a/lisp/org/ox-odt.el b/lisp/org/ox-odt.el index 51cb42a49a5..a1486318a7d 100644 --- a/lisp/org/ox-odt.el +++ b/lisp/org/ox-odt.el @@ -940,7 +940,7 @@ See `org-odt--build-date-styles' for implementation details." (has-time-p (or (not timestamp) (org-timestamp-has-time-p timestamp))) (iso-date (let ((format (if has-time-p "%Y-%m-%dT%H:%M:%S" - "%Y-%m-%dT%H:%M:%S"))) + "%Y-%m-%d"))) (funcall format-timestamp timestamp format end)))) (if iso-date-p iso-date (let* ((style (if has-time-p "OrgDate2" "OrgDate1")) diff --git a/lisp/password-cache.el b/lisp/password-cache.el index 5e5f3240bc3..f5007579a8a 100644 --- a/lisp/password-cache.el +++ b/lisp/password-cache.el @@ -31,7 +31,8 @@ ;; ;; Minibuffer prompt for password. ;; => "foo" ;; -;; (password-cache-add "test" "foo") +;; (password-cache-add "test" (read-passwd "Password? ")) +;; ;; Minibuffer prompt from read-passwd, which returns "foo". ;; => nil ;; (password-read "Password? " "test") diff --git a/lisp/play/animate.el b/lisp/play/animate.el index ff464b68049..8dec55178b1 100644 --- a/lisp/play/animate.el +++ b/lisp/play/animate.el @@ -1,4 +1,4 @@ -;;; animate.el --- make text dance +;;; animate.el --- make text dance -*- lexical-binding:t -*- ;; Copyright (C) 2001-2020 Free Software Foundation, Inc. @@ -84,7 +84,7 @@ (defun animate-place-char (char vpos hpos) (goto-char (window-start)) (let (abbrev-mode) - (dotimes (i vpos) + (dotimes (_ vpos) (end-of-line) (if (= (forward-line 1) 1) (insert "\n")))) diff --git a/lisp/play/bubbles.el b/lisp/play/bubbles.el index 6842cb06302..e5982573792 100644 --- a/lisp/play/bubbles.el +++ b/lisp/play/bubbles.el @@ -80,6 +80,7 @@ ;;; Code: (defconst bubbles-version "0.5" "Version number of bubbles.el.") +(make-obsolete-variable 'bubbles-version nil "28.1") (require 'gamegrid) diff --git a/lisp/play/dissociate.el b/lisp/play/dissociate.el index 3768a14ad82..9a6300c0fd2 100644 --- a/lisp/play/dissociate.el +++ b/lisp/play/dissociate.el @@ -1,4 +1,4 @@ -;;; dissociate.el --- scramble text amusingly for Emacs +;;; dissociate.el --- scramble text amusingly for Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/play/gametree.el b/lisp/play/gametree.el index aa99b553244..ba74afce298 100644 --- a/lisp/play/gametree.el +++ b/lisp/play/gametree.el @@ -324,7 +324,7 @@ This value is simply the outline heading level of the current line." (defun gametree-hack-file-layout () (save-excursion (goto-char (point-min)) - (if (looking-at "[^\n]*-*-[^\n]*gametree-local-layout: \\([^;\n]*\\);") + (if (looking-at "[^\n]*-[^\n]*gametree-local-layout: \\([^;\n]*\\);") (progn (goto-char (match-beginning 1)) (delete-region (point) (match-end 1)) diff --git a/lisp/play/gomoku.el b/lisp/play/gomoku.el index 6e0061d461a..403398672b1 100644 --- a/lisp/play/gomoku.el +++ b/lisp/play/gomoku.el @@ -110,8 +110,8 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map "u" 'gomoku-move-ne) ; u (define-key map "b" 'gomoku-move-sw) ; b (define-key map "n" 'gomoku-move-se) ; n - (define-key map "h" 'backward-char) ; h - (define-key map "l" 'forward-char) ; l + (define-key map "h" 'gomoku-move-left) ; h + (define-key map "l" 'gomoku-move-right) ; l (define-key map "j" 'gomoku-move-down) ; j (define-key map "k" 'gomoku-move-up) ; k @@ -119,11 +119,13 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map [kp-9] 'gomoku-move-ne) (define-key map [kp-1] 'gomoku-move-sw) (define-key map [kp-3] 'gomoku-move-se) - (define-key map [kp-4] 'backward-char) - (define-key map [kp-6] 'forward-char) + (define-key map [kp-4] 'gomoku-move-left) + (define-key map [kp-6] 'gomoku-move-right) (define-key map [kp-2] 'gomoku-move-down) (define-key map [kp-8] 'gomoku-move-up) + (define-key map "\C-b" 'gomoku-move-left) ; C-b + (define-key map "\C-f" 'gomoku-move-right) ; C-f (define-key map "\C-n" 'gomoku-move-down) ; C-n (define-key map "\C-p" 'gomoku-move-up) ; C-p @@ -146,6 +148,10 @@ One useful value to include is `turn-on-font-lock' to highlight the pieces." (define-key map [mouse-2] 'gomoku-mouse-play) (define-key map [drag-mouse-2] 'gomoku-mouse-play) + (define-key map [remap backward-char] 'gomoku-move-left) + (define-key map [remap left-char] 'gomoku-move-left) + (define-key map [remap forward-char] 'gomoku-move-right) + (define-key map [remap right-char] 'gomoku-move-right) (define-key map [remap previous-line] 'gomoku-move-up) (define-key map [remap next-line] 'gomoku-move-down) (define-key map [remap move-beginning-of-line] 'gomoku-beginning-of-line) @@ -954,6 +960,11 @@ If the game is finished, this command requests for another game." ;; 2 instead of 1 because WINDOW-HEIGHT includes the mode line ! gomoku-square-height))) +(defun gomoku-point-x () + "Return the board column where point is." + (1+ (/ (- (current-column) gomoku-x-offset) + gomoku-square-width))) + (defun gomoku-point-y () "Return the board row where point is." (1+ (/ (- (count-lines (point-min) (point)) @@ -1143,13 +1154,28 @@ If the game is finished, this command requests for another game." (skip-chars-forward gomoku--intangible-chars) (when (eobp) (skip-chars-backward gomoku--intangible-chars) - (forward-char -1))) + (gomoku-move-left))) (skip-chars-backward gomoku--intangible-chars) (if (bobp) (skip-chars-forward gomoku--intangible-chars) - (forward-char -1)))) + (gomoku-move-left)))) (setq gomoku--last-pos (point))) +;; forward-char and backward-char don't always move the right number +;; of characters. Also, these functions check if you're on the edge of +;; the screen. +(defun gomoku-move-right () + "Move point right one column on the Gomoku board." + (interactive) + (when (< (gomoku-point-x) gomoku-board-width) + (forward-char gomoku-square-width))) + +(defun gomoku-move-left () + "Move point left one column on the Gomoku board." + (interactive) + (when (> (gomoku-point-x) 1) + (backward-char gomoku-square-width))) + ;; previous-line and next-line don't work right with intangible newlines (defun gomoku-move-down () "Move point down one row on the Gomoku board." @@ -1171,25 +1197,25 @@ If the game is finished, this command requests for another game." "Move point North East on the Gomoku board." (interactive) (gomoku-move-up) - (forward-char)) + (gomoku-move-right)) (defun gomoku-move-se () "Move point South East on the Gomoku board." (interactive) (gomoku-move-down) - (forward-char)) + (gomoku-move-right)) (defun gomoku-move-nw () "Move point North West on the Gomoku board." (interactive) (gomoku-move-up) - (backward-char)) + (gomoku-move-left)) (defun gomoku-move-sw () "Move point South West on the Gomoku board." (interactive) (gomoku-move-down) - (backward-char)) + (gomoku-move-left)) (defun gomoku-beginning-of-line () "Move point to first square on the Gomoku board row." diff --git a/lisp/play/spook.el b/lisp/play/spook.el index 8e69cd971bb..ed91dadcbca 100644 --- a/lisp/play/spook.el +++ b/lisp/play/spook.el @@ -1,4 +1,4 @@ -;;; spook.el --- spook phrase utility for overloading the NSA line eater +;;; spook.el --- spook phrase utility for overloading the NSA line eater -*- lexical-binding:t -*- ;; Copyright (C) 1988, 1993, 2001-2020 Free Software Foundation, Inc. @@ -45,13 +45,11 @@ (defcustom spook-phrases-file (expand-file-name "spook.lines" data-directory) "Keep your favorite phrases here." - :type 'file - :group 'spook) + :type 'file) (defcustom spook-phrase-default-count 15 "Default number of phrases to insert." - :type 'integer - :group 'spook) + :type 'integer) ;;;###autoload (defun spook () diff --git a/lisp/printing.el b/lisp/printing.el index 181092ee999..b8879befae3 100644 --- a/lisp/printing.el +++ b/lisp/printing.el @@ -5622,8 +5622,6 @@ COMMAND.exe, COMMAND.bat and COMMAND.com in this order." ;; header (let ((versions (concat "printing v" pr-version " ps-print v" ps-print-version))) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (widget-insert (make-string (- 79 (length versions)) ?\ ) versions)) (pr-insert-italic "\nCurrent Directory : " 1) (pr-insert-italic default-directory) diff --git a/lisp/progmodes/autoconf.el b/lisp/progmodes/autoconf.el index 5d5811b47d1..d12bed7e27d 100644 --- a/lisp/progmodes/autoconf.el +++ b/lisp/progmodes/autoconf.el @@ -1,4 +1,4 @@ -;;; autoconf.el --- mode for editing Autoconf configure.ac files +;;; autoconf.el --- mode for editing Autoconf configure.ac files -*- lexical-binding: t; -*- ;; Copyright (C) 2000-2020 Free Software Foundation, Inc. diff --git a/lisp/progmodes/bug-reference.el b/lisp/progmodes/bug-reference.el index 75ebc29710c..c52331f84fa 100644 --- a/lisp/progmodes/bug-reference.el +++ b/lisp/progmodes/bug-reference.el @@ -72,7 +72,7 @@ so that it is considered safe, see `enable-local-variables'.") "\\([Bb]ug ?#?\\|[Pp]atch ?#\\|RFE ?#\\|PR [a-z+-]+/\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" "Regular expression matching bug references. The second subexpression should match the bug reference (usually a number)." - :type 'string + :type 'regexp :version "24.3" ; previously defconst :group 'bug-reference) @@ -139,12 +139,312 @@ The second subexpression should match the bug reference (usually a number)." (when url (browse-url url)))))) +(defun bug-reference--maybe-setup-from-vc (url url-rx bug-rx bug-url-fmt) + (when (string-match url-rx url) + (setq-local bug-reference-bug-regexp bug-rx) + (setq-local bug-reference-url-format + (let (groups) + (dotimes (i (/ (length (match-data)) 2)) + (push (match-string i url) groups)) + (funcall bug-url-fmt (nreverse groups)))))) + +(defvar bug-reference-setup-from-vc-alist + `(;; + ;; GNU projects on savannah. + ;; + ;; Not all of them use debbugs but that doesn't really matter + ;; because the auto-setup is only performed if + ;; `bug-reference-url-format' and `bug-reference-bug-regexp' + ;; aren't set already. + ("git\\.\\(?:sv\\|savannah\\)\\.gnu\\.org:" + "\\<\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)\\>" + ,(lambda (_) "https://debbugs.gnu.org/%s")) + ;; + ;; GitHub projects. + ;; + ;; Here #17 may refer to either an issue or a pull request but + ;; visiting the issue/17 web page will automatically redirect to + ;; the pull/17 page if 17 is a PR. Explicit user/project#17 links + ;; to possibly different projects are also supported. + ("[/@]github.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\([.A-Za-z0-9_/-]+\\)?\\(?:#\\)\\([0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://github.com/" + (or + ;; Explicit user/proj#18 link. + (match-string 1) + ns-project) + "/issues/" + (match-string 2)))))) + ;; + ;; GitLab projects. + ;; + ;; Here #18 is an issue and !17 is a merge request. Explicit + ;; namespace/project#18 or namespace/project!17 references to + ;; possibly different projects are also supported. + ("[/@]gitlab.com[/:]\\([.A-Za-z0-9_/-]+\\)\\.git" + "\\(?1:[.A-Za-z0-9_/-]+\\)?\\(?3:[#!]\\)\\(?2:[0-9]+\\)\\>" + ,(lambda (groups) + (let ((ns-project (nth 1 groups))) + (lambda () + (concat "https://gitlab.com/" + (or (match-string 1) + ns-project) + "/-/" + (if (string= (match-string 3) "#") + "issues/" + "merge_requests/") + (match-string 2))))))) + "An alist for setting up `bug-reference-mode' based on VC URL. + +Each element has the form (URL-REGEXP BUG-REGEXP URL-FORMAT-FN). + +URL-REGEXP is matched against the version control URL of the +current buffer's file. If it matches, BUG-REGEXP is set as +`bug-reference-bug-regexp'. URL-FORMAT-FN is a function of one +argument that receives a list of the groups 0 to N of matching +URL-REGEXP against the VCS URL and returns the value to be set as +`bug-reference-url-format'.") + +(defun bug-reference-try-setup-from-vc () + "Try setting up `bug-reference-mode' based on VC information. +Test each configuration in `bug-reference-setup-from-vc-alist' +and apply it if applicable." + (let ((file-or-dir (or buffer-file-name + ;; Catches modes such as vc-dir and Magit. + default-directory))) + (when file-or-dir + (let* ((backend (vc-responsible-backend file-or-dir t)) + (url + (or (ignore-errors + (vc-call-backend backend 'repository-url "upstream")) + (ignore-errors + (vc-call-backend backend 'repository-url))))) + (when url + (catch 'found + (dolist (config bug-reference-setup-from-vc-alist) + (when (apply #'bug-reference--maybe-setup-from-vc + url config) + (throw 'found t))))))))) + +(defvar bug-reference-setup-from-mail-alist + `((,(regexp-opt '("emacs" "auctex" "gnus" "tramp" "orgmode") 'words) + ,(regexp-opt '("@debbugs.gnu.org" "-devel@gnu.org" + ;; List-Id of Gnus devel mailing list. + "ding.gnus.org")) + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in mail modes. + +This takes action if `bug-reference-mode' is enabled in group and +message buffers of Emacs mail clients. Currently, only Gnus is +supported. + +Each element has the form + + (GROUP-REGEXP HEADER-REGEXP BUG-REGEXP URL-FORMAT) + +GROUP-REGEXP is a regexp matched against the current mail folder +or newsgroup name. HEADER-REGEXP is a regexp matched against the +From, To, Cc, Newsgroup, and List-ID header values of the current +mail or newsgroup message. If any of those matches, BUG-REGEXP +is set as `bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'. + +Note: In Gnus, if a summary buffer has been set up based on +GROUP-REGEXP, all article buffers opened from there will get the +same `bug-reference-url-format' and `bug-reference-url-format'.") + +(defvar gnus-newsgroup-name) + +(defun bug-reference--maybe-setup-from-mail (group header-values) + "Set up according to mail GROUP or HEADER-VALUES. +Group is a mail group/folder name and HEADER-VALUES is a list of +mail header values, e.g., the values of From, To, Cc, List-ID, +and Newsgroup. + +If any GROUP-REGEXP or HEADER-REGEXP of +`bug-reference-setup-from-mail-alist' matches GROUP or any +element in HEADER-VALUES, the corresponding BUG-REGEXP and +URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-mail-alist) + (when (or + (and group + (car config) + (string-match-p (car config) group)) + (and header-values + (nth 1 config) + (catch 'matching-header + (dolist (h header-values) + (when (and h (string-match-p (nth 1 config) h)) + (throw 'matching-header t)))))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))) + +(defun bug-reference-try-setup-from-gnus () + "Try setting up `bug-reference-mode' based on Gnus group or article. +Test each configuration in `bug-reference-setup-from-mail-alist' +and set it if applicable." + (when (and (derived-mode-p 'gnus-summary-mode) + (bound-and-true-p gnus-newsgroup-name)) + ;; Gnus reuses its article buffer so we have to check whenever the + ;; article changes. + (add-hook 'gnus-article-prepare-hook + #'bug-reference--try-setup-gnus-article) + (bug-reference--maybe-setup-from-mail gnus-newsgroup-name nil))) + +(defvar gnus-article-buffer) +(defvar gnus-original-article-buffer) +(defvar gnus-summary-buffer) + +(defun bug-reference--try-setup-gnus-article () + (with-demoted-errors + "Error in bug-reference--try-setup-gnus-article: %S" + (when (and bug-reference-mode ;; Only if enabled in article buffers. + (derived-mode-p + 'gnus-article-mode + ;; Apparently, gnus-article-prepare-hook is run in the + ;; summary buffer... + 'gnus-summary-mode) + gnus-article-buffer + gnus-original-article-buffer + (buffer-live-p (get-buffer gnus-article-buffer)) + (buffer-live-p (get-buffer gnus-original-article-buffer))) + (with-current-buffer gnus-article-buffer + (catch 'setup-done + ;; Copy over the values from the summary buffer. + (when (and gnus-summary-buffer + (buffer-live-p gnus-summary-buffer)) + (setq-local bug-reference-bug-regexp + (with-current-buffer gnus-summary-buffer + bug-reference-bug-regexp)) + (setq-local bug-reference-url-format + (with-current-buffer gnus-summary-buffer + bug-reference-url-format)) + (when (and bug-reference-bug-regexp + bug-reference-url-format) + (throw 'setup-done t))) + ;; If the summary had no values, try setting according to + ;; the values of the From, To, and Cc headers. + (let (header-values) + (with-current-buffer + (get-buffer gnus-original-article-buffer) + (save-excursion + (goto-char (point-min)) + ;; The Newsgroup is omitted because we already matched + ;; based on group name in the summary buffer. + (dolist (field '("list-id" "to" "from" "cc")) + (let ((val (mail-fetch-field field))) + (when val + (push val header-values)))))) + (bug-reference--maybe-setup-from-mail nil header-values))))))) + +(defvar bug-reference-setup-from-irc-alist + `((,(concat "#" (regexp-opt '("emacs" "gnus" "org-mode" "rcirc" + "erc") 'words)) + "freenode" + "\\([Bb]ug ?#?\\)\\([0-9]+\\(?:#[0-9]+\\)?\\)" + "https://debbugs.gnu.org/%s")) + "An alist for setting up `bug-reference-mode' in IRC modes. + +This takes action if `bug-reference-mode' is enabled in IRC +channels using one of Emacs' IRC clients (rcirc and ERC). +Currently, rcirc and ERC are supported. + +Each element has the form + + (CHANNEL-REGEXP NETWORK-REGEXP BUG-REGEXP URL-FORMAT) + +CHANNEL-REGEXP is a regexp matched against the current IRC +channel name (e.g. #emacs). NETWORK-REGEXP is matched against +the IRC network name (e.g. freenode). Both entries are optional. +If all given entries match, BUG-REGEXP is set as +`bug-reference-bug-regexp' and URL-FORMAT is set as +`bug-reference-url-format'.") + +(defun bug-reference--maybe-setup-from-irc (channel network) + "Set up according to IRC CHANNEL or NETWORK. +CHANNEL is an IRC channel name (or generally a target, i.e., it +could also be a user name) and NETWORK is that channel's network +name. + +If any `bug-reference-setup-from-irc-alist' entry's +CHANNEL-REGEXP and NETWORK-REGEXP match CHANNEL and NETWORK, the +corresponding BUG-REGEXP and URL-FORMAT are set." + (catch 'setup-done + (dolist (config bug-reference-setup-from-irc-alist) + (let ((channel-rx (car config)) + (network-rx (nth 1 config))) + (when (and + ;; One of both has to be given. + (or channel-rx network-rx) + ;; The args have to be set. + channel network) + (when (and + (or (null channel-rx) + (string-match-p channel-rx channel)) + (or (null network-rx) + (string-match-p network-rx network))) + (setq-local bug-reference-bug-regexp (nth 2 config)) + (setq-local bug-reference-url-format (nth 3 config)) + (throw 'setup-done t))))))) + +(defvar rcirc-target) +(defvar rcirc-server-buffer) +(defvar rcirc-server) + +(defun bug-reference-try-setup-from-rcirc () + "Try setting up `bug-reference-mode' based on rcirc channel and server. +Test each configuration in `bug-reference-setup-from-irc-alist' +and set it if applicable." + (when (derived-mode-p 'rcirc-mode) + (bug-reference--maybe-setup-from-irc + rcirc-target + (and rcirc-server-buffer + (buffer-live-p rcirc-server-buffer) + (with-current-buffer rcirc-server-buffer + rcirc-server))))) + +(declare-function erc-format-target "erc") +(declare-function erc-network-name "erc-networks") + +(defun bug-reference-try-setup-from-erc () + "Try setting up `bug-reference-mode' based on ERC channel and server. +Test each configuration in `bug-reference-setup-from-irc-alist' +and set it if applicable." + (when (derived-mode-p 'erc-mode) + (bug-reference--maybe-setup-from-irc + (erc-format-target) + (erc-network-name)))) + +(defun bug-reference--run-auto-setup () + (when (or bug-reference-mode + bug-reference-prog-mode) + ;; Automatic setup only if the variables aren't already set, e.g., + ;; by a local variables section in the file. + (unless (and bug-reference-bug-regexp + bug-reference-url-format) + (with-demoted-errors + "Error during bug-reference auto-setup: %S" + (catch 'setup + (dolist (f (list #'bug-reference-try-setup-from-vc + #'bug-reference-try-setup-from-gnus + #'bug-reference-try-setup-from-rcirc + #'bug-reference-try-setup-from-erc)) + (when (funcall f) + (throw 'setup t)))))))) + ;;;###autoload (define-minor-mode bug-reference-mode "Toggle hyperlinking bug references in the buffer (Bug Reference mode)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) @@ -158,6 +458,7 @@ The second subexpression should match the bug reference (usually a number)." nil "" nil + :after-hook (bug-reference--run-auto-setup) (if bug-reference-prog-mode (jit-lock-register #'bug-reference-fontify) (jit-lock-unregister #'bug-reference-fontify) diff --git a/lisp/progmodes/cc-align.el b/lisp/progmodes/cc-align.el index f30477dc787..6172afecbcf 100644 --- a/lisp/progmodes/cc-align.el +++ b/lisp/progmodes/cc-align.el @@ -790,6 +790,38 @@ arglist-cont-nonempty." (or (c-lineup-assignments langelem) c-basic-offset)) +(defun c-lineup-ternary-bodies (langelem) + "Line up true and false branches of a ternary operator (i.e. `?:'). +More precisely, if the line starts with a colon which is a part of +a said operator, align it with corresponding question mark; otherwise +return nil. For example: + + return arg % 2 == 0 ? arg / 2 + : (3 * arg + 1); <- c-lineup-ternary-bodies + +Works with: arglist-cont, arglist-cont-nonempty and statement-cont." + (save-excursion + (back-to-indentation) + (when (and (eq ?: (char-after)) + (not (eq ?: (char-after (1+ (point)))))) + (let ((limit (c-langelem-pos langelem)) (depth 1)) + (catch 'done + (while (and (c-syntactic-skip-backward "^?:" limit t) + (not (bobp))) + (backward-char) + (cond ((eq (char-after) ??) + ;; If we've found a question mark, decrease depth. If we've + ;; reached zero, we've found the one we were looking for. + (when (zerop (setq depth (1- depth))) + (throw 'done (vector (current-column))))) + ((or (eq ?: (char-before)) (eq ?? (char-before))) + ;; Step over `::' and `?:' operators. We don't have to + ;; handle `?:' here but doing so saves an iteration. + (if (eq (point) limit) + (throw 'done nil) + (goto-char (1- (point))))) + ((setq depth (1+ depth)))))))))) ; Otherwise increase depth. + (defun c-lineup-cascaded-calls (langelem) "Line up \"cascaded calls\" under each other. If the line begins with \"->\" or \".\" and the preceding line ends diff --git a/lisp/progmodes/cc-awk.el b/lisp/progmodes/cc-awk.el index fd61e3e3287..52e6da6f4ac 100644 --- a/lisp/progmodes/cc-awk.el +++ b/lisp/progmodes/cc-awk.el @@ -1003,7 +1003,7 @@ std\\(err\\|in\\|out\\)\\|user\\)\\)\\>\ ;; Matches an unterminated string/regexp, NOT including the eol at the end. (defconst c-awk-harmless-pattern-characters* - (concat "\\([^{;#/\"\\\\\n\r]\\|" c-awk-esc-pair-re "\\)*")) + (concat "\\([^{;#/\"\\\n\r]\\|" c-awk-esc-pair-re "\\)*")) ;; Matches any "harmless" character in a pattern or an escaped character pair. (defun c-awk-at-statement-end-p () diff --git a/lisp/progmodes/cc-cmds.el b/lisp/progmodes/cc-cmds.el index 1071191775b..1b557c41a5d 100644 --- a/lisp/progmodes/cc-cmds.el +++ b/lisp/progmodes/cc-cmds.el @@ -48,6 +48,7 @@ (cc-bytecomp-defvar filladapt-mode) ; c-fill-paragraph contains a kludge ; which looks at this. (cc-bytecomp-defun electric-pair-post-self-insert-function) +(cc-bytecomp-defvar c-indent-to-body-directives) ;; Indentation / Display syntax functions (defvar c-fix-backslashes t) @@ -512,11 +513,11 @@ function to control that." (let ((src (default-value 'post-self-insert-hook))) (while src (unless (memq (car src) c--unsafe-post-self-insert-hook-functions) - (add-hook 'dest (car src) t)) ; Preserve the order of the functions. + (push (car src) dest)) (setq src (cdr src))))) - (t (add-hook 'dest (car src) t))) ; Preserve the order of the functions. + (t (push (car src) dest))) (setq src (cdr src))) - (run-hooks 'dest))) + (mapc #'funcall (nreverse dest)))) ; Preserve the order of the functions. (defmacro c--call-post-self-insert-hook-more-safely () ;; Call post-self-insert-hook, if such exists. See comment for @@ -1441,6 +1442,98 @@ keyword on the line, the keyword is not inserted inside a literal, and (indent-according-to-mode) (delete-char -2))))) +(defun c-align-cpp-indent-to-body () + "Align a \"#pragma\" line under the previous line. +This function is intented for use as a member of `c-special-indent-hook'." + (when (assq 'cpp-macro c-syntactic-context) + (when + (save-excursion + (save-match-data + (back-to-indentation) + (and + (looking-at (concat c-opt-cpp-symbol "[ \t]*\\([a-zA-Z0-9_]+\\)")) + (member (match-string-no-properties 1) + c-cpp-indent-to-body-directives)))) + (c-indent-line (delete '(cpp-macro) c-syntactic-context))))) + +(defvar c-cpp-indent-to-body-flag nil) +;; Non-nil when CPP directives such as "#pragma" should be indented to under +;; the preceding statement. +(make-variable-buffer-local 'c-cpp-indent-to-body-flag) + +(defun c-electric-pragma () + "Reindent the current line if appropriate. + +This function is used to reindent a preprocessor line when the +symbol for the directive, typically \"pragma\", triggers this +function as a hook function of an abbreviation. + +The \"#\" of the preprocessor construct is aligned under the +first anchor point of the line's syntactic context. + +The line is reindented if the construct is not in a string or +comment, there is exactly one \"#\" contained in optional +whitespace before it on the current line, and `c-electric-flag' +and `c-syntactic-indentation' are both non-nil." + (save-excursion + (save-match-data + (when + (and + c-cpp-indent-to-body-flag + c-electric-flag + c-syntactic-indentation + last-abbrev-location + c-opt-cpp-symbol ; "#" or nil. + (progn (back-to-indentation) + (looking-at (concat c-opt-cpp-symbol "[ \t]*"))) + (>= (match-end 0) last-abbrev-location) + (not (c-literal-limits))) + (c-indent-line (delete '(cpp-macro) (c-guess-basic-syntax))))))) + +(defun c-add-indent-to-body-to-abbrev-table (d) + ;; Create an abbreviation table entry for the directive D, and add it to the + ;; current abbreviation table. Existing abbreviation (e.g. for "else") do + ;; not get overwritten. + (when (and c-buffer-is-cc-mode + local-abbrev-table + (not (abbrev-symbol d local-abbrev-table))) + (condition-case nil + (define-abbrev local-abbrev-table d d 'c-electric-pragma 0 t) + (wrong-number-of-arguments + (define-abbrev local-abbrev-table d d 'c-electric-pragma))))) + +(defun c-clear-stale-indent-to-body-abbrevs () + ;; Fill in this comment. FIXME!!! + (when (fboundp 'abbrev-get) + (mapatoms (lambda (a) + (when (and (abbrev-get a ':system) ; Preserve a user's abbrev! + (not (member (symbol-name a) c-std-abbrev-keywords)) + (not (member (symbol-name a) + c-cpp-indent-to-body-directives))) + (unintern a local-abbrev-table))) + local-abbrev-table))) + +(defun c-toggle-cpp-indent-to-body (&optional arg) + "Toggle the C preprocessor indent-to-body feature. +When enabled, preprocessor directives which are words in +`c-indent-to-body-directives' are indented as if they were statements. + +Optional numeric ARG, if supplied, turns on the feature when positive, +turns it off when negative, and just toggles it when zero or +left out." + (interactive "P") + (setq c-cpp-indent-to-body-flag + (c-calculate-state arg c-cpp-indent-to-body-flag)) + (if c-cpp-indent-to-body-flag + (progn + (c-clear-stale-indent-to-body-abbrevs) + (mapc 'c-add-indent-to-body-to-abbrev-table + c-cpp-indent-to-body-directives) + (add-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body nil t)) + (remove-hook 'c-special-indent-hook 'c-align-cpp-indent-to-body t)) + (message "c-cpp-indent-to-body %sabled" + (if c-cpp-indent-to-body-flag "en" "dis"))) + (declare-function subword-forward "subword" (&optional arg)) @@ -2024,6 +2117,23 @@ other top level construct with a brace block." (c-backward-syntactic-ws) (point)))) + ((and (c-major-mode-is 'objc-mode) (looking-at "[-+]\\s-*(")) ; Objective-C method + ;; Move to the beginning of the method name. + (c-forward-token-2 2 t) + (let* ((class + (save-excursion + (when (re-search-backward + "^\\s-*@\\(implementation\\|class\\|interface\\)\\s-+\\(\\sw+\\)" nil t) + (match-string-no-properties 2)))) + (limit (save-excursion (re-search-forward "[;{]" nil t))) + (method (when (re-search-forward "\\(\\sw+:?\\)" limit t) + (match-string-no-properties 1)))) + (when (and class method) + ;; Add the parameter labels onto name. They always end in ':'. + (while (re-search-forward "\\(\\sw+:\\)" limit 1) + (setq method (concat method (match-string-no-properties 1)))) + (concat "[" class " " method "]")))) + (t ; Normal function or initializer. (when (looking-at c-defun-type-name-decl-key) ; struct, etc. (goto-char (match-end 0)) diff --git a/lisp/progmodes/cc-defs.el b/lisp/progmodes/cc-defs.el index a1e3a236a11..9a3d7adf61d 100644 --- a/lisp/progmodes/cc-defs.el +++ b/lisp/progmodes/cc-defs.el @@ -87,7 +87,7 @@ ;;; Variables also used at compile time. -(defconst c-version "5.34.1" +(defconst c-version "5.34.2" "CC Mode version number.") (defconst c-version-sym (intern c-version)) @@ -445,6 +445,15 @@ to it is returned. This function does not modify the point or the mark." ;; Emacs and earlier XEmacs `(next-single-property-change ,position ,prop ,object ,limit))) +(defmacro c-previous-single-property-change (position prop &optional object limit) + ;; See the doc string for either of the defuns expanded to. + (if (and c-use-extents + (fboundp 'previous-single-char-property-change)) + ;; XEmacs >= 2005-01-25 + `(previous-single-char-property-change ,position ,prop ,object ,limit) + ;; Emacs and earlier XEmacs + `(previous-single-property-change ,position ,prop ,object ,limit))) + (defmacro c-region-is-active-p () ;; Return t when the region is active. The determination of region ;; activeness is different in both Emacs and XEmacs. @@ -1047,15 +1056,6 @@ MODE is either a mode symbol or a list of mode symbols." ;; properties set on a single character and that never spread to any ;; other characters. -(defmacro c-put-syn-tab (pos value) - ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to - ;; VALUE (which should not be nil). - `(let ((-pos- ,pos) - (-value- ,value)) - (c-put-char-property -pos- 'syntax-table -value-) - (c-put-char-property -pos- 'c-fl-syn-tab -value-) - (c-truncate-lit-pos-cache -pos-))) - (eval-and-compile ;; Constant used at compile time to decide whether or not to use ;; XEmacs extents. Check all the extent functions we'll use since @@ -1183,13 +1183,6 @@ MODE is either a mode symbol or a list of mode symbols." ;; Emacs < 21. `(c-clear-char-property-fun ,pos ',property)))) -(defmacro c-clear-syn-tab (pos) - ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. - `(let ((-pos- ,pos)) - (c-clear-char-property -pos- 'syntax-table) - (c-clear-char-property -pos- 'c-fl-syn-tab) - (c-truncate-lit-pos-cache -pos-))) - (defmacro c-min-property-position (from to property) ;; Return the first position in the range [FROM to) where the text property ;; PROPERTY is set, or `most-positive-fixnum' if there is no such position. @@ -1235,8 +1228,18 @@ MODE is either a mode symbol or a list of mode symbols." ;; Remove all occurrences of the `syntax-table' and `c-fl-syn-tab' text ;; properties between FROM and TO. `(let ((-from- ,from) (-to- ,to)) - (c-clear-char-properties -from- -to- 'syntax-table) - (c-clear-char-properties -from- -to- 'c-fl-syn-tab))) + (when (and + c-min-syn-tab-mkr c-max-syn-tab-mkr + (< -from- c-max-syn-tab-mkr) + (> -to- c-min-syn-tab-mkr)) + (let ((pos -from-)) + (while (and + (< pos -to-) + (setq pos (c-min-property-position pos -to- 'c-fl-syn-tab)) + (< pos -to-)) + (c-clear-syn-tab pos) + (setq pos (1+ pos))))) + (c-clear-char-properties -from- -to- 'syntax-table))) (defmacro c-search-forward-char-property (property value &optional limit) "Search forward for a text-property PROPERTY having value VALUE. @@ -1456,28 +1459,6 @@ with value CHAR in the region [FROM to)." (c-put-char-property (point) ,property ,value) (forward-char))))) -(defmacro c-with-extended-string-fences (beg end &rest body) - ;; If needed, extend the region with "mirrored" c-fl-syn-tab properties to - ;; contain the region (BEG END), then evaluate BODY. If this mirrored - ;; region was initially empty, restore it afterwards. - `(let ((-beg- ,beg) - (-end- ,end) - ) - (cond - ((null c-fl-syn-tab-region) - (unwind-protect - (progn - (c-restore-string-fences -beg- -end-) - ,@body) - (c-clear-string-fences))) - ((and (>= -beg- (car c-fl-syn-tab-region)) - (<= -end- (cdr c-fl-syn-tab-region))) - ,@body) - (t ; Crudely extend the mirrored region. - (setq -beg- (min -beg- (car c-fl-syn-tab-region)) - -end- (max -end- (cdr c-fl-syn-tab-region))) - (c-restore-string-fences -beg- -end-) - ,@body)))) ;; Macros to put overlays (Emacs) or extents (XEmacs) on buffer text. ;; For our purposes, these are characterized by being possible to diff --git a/lisp/progmodes/cc-engine.el b/lisp/progmodes/cc-engine.el index bccef6890f8..c3a98d9c5cf 100644 --- a/lisp/progmodes/cc-engine.el +++ b/lisp/progmodes/cc-engine.el @@ -163,7 +163,9 @@ (defvar c-doc-line-join-re) (defvar c-doc-bright-comment-start-re) (defvar c-doc-line-join-end-ch) -(defvar c-fl-syn-tab-region) +(cc-bytecomp-defvar c-min-syn-tab-mkr) +(cc-bytecomp-defvar c-max-syn-tab-mkr) +(cc-bytecomp-defun c-clear-syn-tab) (cc-bytecomp-defun c-clear-string-fences) (cc-bytecomp-defun c-restore-string-fences) @@ -405,7 +407,7 @@ comment at the start of cc-engine.el for more info." (when (and (car c-macro-cache) (> (point) (car c-macro-cache)) ; in case we have a ; zero-sized region. - (not (eq (char-before (1- (point))) ?\\))) + (not lim)) (setcdr c-macro-cache (point)) (setq c-macro-cache-syntactic nil))))))) @@ -1580,6 +1582,7 @@ comment at the start of cc-engine.el for more info." (save-excursion (backward-char) (looking-at "\\s(")) (c-crosses-statement-barrier-p (point) end))))) +(make-obsolete 'c-at-expression-start-p nil "CC mode 5.35") ;; A set of functions that covers various idiosyncrasies in @@ -1642,6 +1645,21 @@ comment at the start of cc-engine.el for more info." (forward-char 2) t)))) +(defmacro c-forward-comment-minus-1 () + "Call (forward-comment -1), taking care of escaped newlines. +Return the result of `forward-comment' if it gets called, nil otherwise." + `(if (not comment-end-can-be-escaped) + (forward-comment -1) + (when (and (< (skip-syntax-backward " >") 0) + (eq (char-after) ?\n)) + (forward-char)) + (cond + ((and (eq (char-before) ?\n) + (eq (char-before (1- (point))) ?\\)) + (backward-char) + nil) + (t (forward-comment -1))))) + (defun c-backward-single-comment () "Move backward past whitespace and the closest preceding comment, if any. Return t if a comment was found, nil otherwise. In either case, the @@ -1675,12 +1693,12 @@ This function does not do any hidden buffer changes." ;; same line. (re-search-forward "\\=\\s *[\n\r]" start t) - (if (if (forward-comment -1) + (if (if (c-forward-comment-minus-1) (if (eolp) ;; If forward-comment above succeeded and we're at eol ;; then the newline we moved over above didn't end a ;; line comment, so we give it another go. - (forward-comment -1) + (c-forward-comment-minus-1) t)) ;; Emacs <= 20 and XEmacs move back over the closer of a @@ -1709,7 +1727,7 @@ comment at the start of cc-engine.el for more info." (if (let (moved-comment) (while - (and (not (setq moved-comment (forward-comment -1))) + (and (not (setq moved-comment (c-forward-comment-minus-1))) ;; Cope specifically with ^M^J here - ;; forward-comment sometimes gets stuck after ^Ms, ;; sometimes after ^M^J. @@ -1895,52 +1913,29 @@ comment at the start of cc-engine.el for more info." (defun c-enclosing-c++-attribute () ;; If we're in C++ Mode, and point is within a correctly balanced [[ ... ]] ;; attribute structure, return a cons of its starting and ending positions. - ;; Otherwise, return nil. We use the c-{in,is}-sws-face text properties for - ;; this determination, this macro being intended only for use in the *-sws-* - ;; functions and macros. The match data are NOT preserved over this macro. - (let (attr-end pos-is-sws) - (and - (c-major-mode-is 'c++-mode) - (> (point) (point-min)) - (setq pos-is-sws - (if (get-text-property (1- (point)) 'c-is-sws) - (1- (point)) - (1- (previous-single-property-change - (point) 'c-is-sws nil (point-min))))) - (save-excursion - (goto-char pos-is-sws) - (setq attr-end (c-looking-at-c++-attribute))) - (> attr-end (point)) - (cons pos-is-sws attr-end)))) - -(defun c-slow-enclosing-c++-attribute () - ;; Like `c-enclosing-c++-attribute', but does not depend on the c-i[ns]-sws - ;; properties being set. + ;; Otherwise, return nil. (and (c-major-mode-is 'c++-mode) (save-excursion - (let ((paren-state (c-parse-state)) + (let ((lim (max (- (point) 200) (point-min))) cand) (while - (progn - (setq cand - (catch 'found-cand - (while (cdr paren-state) - (when (and (numberp (car paren-state)) - (numberp (cadr paren-state)) - (eq (car paren-state) - (1+ (cadr paren-state))) - (eq (char-after (car paren-state)) ?\[) - (eq (char-after (cadr paren-state)) ?\[)) - (throw 'found-cand (cadr paren-state))) - (setq paren-state (cdr paren-state))))) - (and cand - (not - (and (c-go-list-forward cand) - (eq (char-before) ?\]) - (eq (char-before (1- (point))) ?\]))))) - (setq paren-state (cdr paren-state))) - (and cand (cons cand (point))))))) + (and + (progn + (skip-chars-backward "^[;{}" lim) + (eq (char-before) ?\[)) + (not (eq (char-before (1- (point))) ?\[)) + (> (point) lim)) + (backward-char)) + (and (eq (char-before) ?\[) + (eq (char-before (1- (point))) ?\[) + (progn (backward-char 2) t) + (setq cand (point)) + (c-go-list-forward nil (min (+ (point) 200) (point-max))) + (eq (char-before) ?\]) + (eq (char-before (1- (point))) ?\]) + (not (c-literal-limits)) + (cons cand (point))))))) (defun c-invalidate-sws-region-before (beg end) ;; Called from c-before-change. BEG and END are the bounds of the change @@ -2988,9 +2983,7 @@ comment at the start of cc-engine.el for more info." c-block-comment-awkward-chars))) (and (nth 4 s) (nth 7 s) ; Line comment (not (memq (char-before here) '(?\\ ?\n))))))) - (c-with-extended-string-fences - pos here - (setq s (parse-partial-sexp pos here nil nil s)))) + (setq s (parse-partial-sexp pos here nil nil s))) (when (not (eq near-pos here)) (c-semi-put-near-cache-entry here s)) (cond @@ -3122,7 +3115,7 @@ comment at the start of cc-engine.el for more info." (not base) ; FIXME!!! Compare base and far-base?? ; (2019-05-21) (not end) - (> here end)) + (>= here end)) (progn (setq far-base-and-state (c-parse-ps-state-below here) far-base (car far-base-and-state) @@ -3135,7 +3128,7 @@ comment at the start of cc-engine.el for more info." (or (and (> here base) (null end)) (null (nth 8 s)) - (and end (> here end)) + (and end (>= here end)) (not (or (and (nth 3 s) ; string @@ -3194,6 +3187,24 @@ comment at the start of cc-engine.el for more info." c-semi-near-cache-limit (min c-semi-near-cache-limit pos) c-full-near-cache-limit (min c-full-near-cache-limit pos))) +(defun c-foreign-truncate-lit-pos-cache (beg _end) + "Truncate CC Mode's literal cache. + +This function should be added to the `before-change-functions' +hook by major modes that use CC Mode's filling functionality +without initializing CC Mode. Currently (2020-06) these are +js-mode and mhtml-mode." + (c-truncate-lit-pos-cache beg)) + +(defun c-foreign-init-lit-pos-cache () + "Initialize CC Mode's literal cache. + +This function should be called from the mode functions of major +modes which use CC Mode's filling functionality without +initializing CC Mode. Currently (2020-06) these are js-mode and +mhtml-mode." + (c-truncate-lit-pos-cache 1)) + ;; A system for finding noteworthy parens before the point. @@ -11685,7 +11696,16 @@ comment at the start of cc-engine.el for more info." (not (c-in-literal)) )))) nil) - (t t)))))) + (t t))))) + ((and + (c-major-mode-is 'c++-mode) + (eq (char-after) ?\[) + ;; Be careful of "operator []" + (not (save-excursion + (c-backward-token-2 1 nil lim) + (looking-at c-opt-op-identifier-prefix)))) + (setq braceassignp t) + nil)) (when (eq braceassignp 'dontknow) (cond ((and (not (eq (char-after) ?,)) @@ -11876,17 +11896,6 @@ comment at the start of cc-engine.el for more info." (cons (list beg) type))))) (error nil)))) -(defun c-looking-at-bos (&optional _lim) - ;; Return non-nil if between two statements or declarations, assuming - ;; point is not inside a literal or comment. - ;; - ;; Obsolete - `c-at-statement-start-p' or `c-at-expression-start-p' - ;; are recommended instead. - ;; - ;; This function might do hidden buffer changes. - (c-at-statement-start-p)) -(make-obsolete 'c-looking-at-bos 'c-at-statement-start-p "22.1") - (defun c-looking-at-statement-block () ;; Point is at an opening brace. If this is a statement block (i.e. the ;; elements in the block are terminated by semicolons, or the block is @@ -12057,7 +12066,7 @@ comment at the start of cc-engine.el for more info." (c-backward-token-2 1 nil lim) (and (not (and (c-on-identifier) - (looking-at c-symbol-chars))) + (looking-at c-symbol-char-key))) (not (looking-at c-opt-op-identifier-prefix))))))) (cons 'inlambda bracket-pos)) ((and c-recognize-paren-inexpr-blocks diff --git a/lisp/progmodes/cc-fonts.el b/lisp/progmodes/cc-fonts.el index 2cbbc66c14f..386cc2f16fe 100644 --- a/lisp/progmodes/cc-fonts.el +++ b/lisp/progmodes/cc-fonts.el @@ -3016,6 +3016,84 @@ need for `pike-font-lock-extra-types'.") (c-font-lock-doc-comments "/[*/]!" limit autodoc-font-lock-doc-comments))))) +;; Doxygen + +(defconst doxygen-font-lock-doc-comments + ;; TODO: Handle @code, @verbatim, @dot, @f etc. better by not highlighting + ;; text inside of those commands. Something smarter than just regexes may be + ;; needed to do that efficiently. + `((,(concat + ;; Make sure that the special character has not been escaped. E.g. in + ;; `\@foo' only `\@' is a command (similarly for other characters like + ;; `\\foo', `\<foo' and `\&foo'). The downside now is that we don't + ;; match command started just after an escaped character, e.g. in + ;; `\@\foo' we should match `\@' as well as `\foo' but only the former + ;; is matched. + "\\(?:^\\|[^\\@]\\)\\(" + ;; Doxygen commands start with backslash or an at sign. Note that for + ;; brevity in the comments only `\' will be mentioned. + "[\\@]\\(?:" + ;; Doxygen commands except those starting with `f' + "[a-eg-z][a-z]*" + ;; Doxygen command starting with `f': + "\\|f\\(?:" + "[][$}]" ; \f$ \f} \f[ \f] + "\\|{\\(?:[a-zA-Z]+\\*?}{?\\)?" ; \f{ \f{env} \f{env}{ + "\\|[a-z]+" ; \foo + "\\)" + "\\|~[a-zA-Z]*" ; \~ \~language + "\\|[$@&~<=>#%\".|\\\\]" ; single-character escapes + "\\|::\\|---?" ; \:: \-- \--- + "\\)" + ;; HTML tags and entities: + "\\|</?\\sw\\(?:\\sw\\|\\s \\|[=\n\r*.:]\\|\"[^\"]*\"\\|'[^']*'\\)*>" + "\\|&\\(?:\\sw+\\|#[0-9]+\\|#x[0-9a-fA-F]+\\);" + "\\)") + 1 ,c-doc-markup-face-name prepend nil) + ;; Commands inside of strings are not commands so override highlighting with + ;; string face. This also affects HTML attribute values if they are + ;; surrounded with double quotes which may or may not be considered a good + ;; thing. + ("\\(?:^\\|[^\\@]\\)\\(\"[^\"[:cntrl:]]+\"\\)" + 1 font-lock-string-face prepend nil) + ;; HTML comments inside of the Doxygen comments. + ("\\(?:^\\|[^\\@]\\)\\(<!--.*?-->\\)" + 1 font-lock-comment-face prepend nil) + ;; Autolinking. Doxygen auto-links anything that is a class name but we have + ;; no hope of matching those. We are, however, able to match functions and + ;; members using explicit scoped syntax. For functions, we can also find + ;; them by noticing argument-list. Note that Doxygen accepts `::' as well + ;; as `#' as scope operators. + (,(let* ((ref "[\\@]ref\\s-+") + (ref-opt (concat "\\(?:" ref "\\)?")) + (id "[a-zA-Z_][a-zA-Z_0-9]*") + (args "\\(?:()\\|([^()]*)\\)") + (scope "\\(?:#\\|::\\)")) + (concat + "\\(?:^\\|[^\\@/%:]\\)\\(?:" + ref-opt "\\(?1:" scope "?" "\\(?:" id scope "\\)+" "~?" id "\\)" + "\\|" ref-opt "\\(?1:" scope "~?" id "\\)" + "\\|" ref-opt "\\(?1:" scope "?" "~?" id "\\)" args + "\\|" ref "\\(?1:" "~?" id "\\)" + "\\|" ref-opt "\\(?1:~[A-Z][a-zA-Z0-9_]+\\)" + "\\)")) + 1 font-lock-function-name-face prepend nil) + ;; Match URLs and emails. This has two purposes. First of all, Doxygen + ;; autolinks URLs. Second of all, `@bar' in `foo@bar.baz' has been matched + ;; above as a command; try and overwrite it. + (,(let* ((host "[A-Za-z0-9]\\(?:[A-Za-z0-9-]\\{0,61\\}[A-Za-z0-9]\\)") + (fqdn (concat "\\(?:" host "\\.\\)+" host)) + (comp "[!-(*--/-=?-~]+") + (path (concat "/\\(?:" comp "[.]+" "\\)*" comp))) + (concat "\\(?:mailto:\\)?[a-zA-0_.]+@" fqdn + "\\|https?://" fqdn "\\(?:" path "\\)?")) + 0 font-lock-keyword-face prepend nil))) + +(defconst doxygen-font-lock-keywords + `((,(lambda (limit) + (c-font-lock-doc-comments "/\\(?:/[/!]\\|\\*[\\*!]\\)" + limit doxygen-font-lock-doc-comments))))) + ;; 2006-07-10: awk-font-lock-keywords has been moved back to cc-awk.el. (cc-provide 'cc-fonts) diff --git a/lisp/progmodes/cc-langs.el b/lisp/progmodes/cc-langs.el index e7e7cfd4b09..b77bf3303b6 100644 --- a/lisp/progmodes/cc-langs.el +++ b/lisp/progmodes/cc-langs.el @@ -1174,7 +1174,7 @@ since CC Mode treats every identifier as an expression." ;; Exception. ,@(when (c-major-mode-is 'c++-mode) - '((prefix "throw"))) + '((prefix "throw" "co_await" "co_yield"))) ;; Sequence. (left-assoc ",")) @@ -1769,7 +1769,7 @@ ender." `comment-start-skip' is initialized from this." ;; Default: Allow the last char of the comment starter(s) to be ;; repeated, then allow any amount of horizontal whitespace. - t (concat "\\(" + t (concat "\\(?:" (c-concat-separated (mapcar (lambda (cs) (when cs @@ -2040,6 +2040,7 @@ the appropriate place for that." (c-lang-defconst c-return-kwds "Keywords which return a value to the calling function." t '("return") + c++ '("return" "co_return") idl nil) (c-lang-defconst c-return-key @@ -2415,7 +2416,8 @@ If any of these also are on `c-type-list-kwds', `c-ref-list-kwds', `c-<>-type-kwds', or `c-<>-arglist-kwds' then the associated clauses will be handled." t nil - objc '("@class" "@end" "@defs") + objc '("@class" "@defs" "@end" "@property" "@dynamic" "@synthesize" + "@compatibility_alias") java '("import" "package") pike '("import" "inherit")) @@ -2538,7 +2540,8 @@ one of `c-type-list-kwds', `c-ref-list-kwds', "Access protection label keywords in classes." t nil c++ '("private" "protected" "public") - objc '("@private" "@protected" "@public")) + objc '("@private" "@protected" "@package" "@public" + "@required" "@optional")) (c-lang-defconst c-protection-key ;; A regexp match an element of `c-protection-kwds' cleanly. @@ -2753,7 +2756,7 @@ identifiers that follows the type in a normal declaration." "Statement keywords followed directly by a substatement." t '("do" "else") c++ '("do" "else" "try") - objc '("do" "else" "@finally" "@try") + objc '("do" "else" "@finally" "@try" "@autoreleasepool") java '("do" "else" "finally" "try") idl nil) @@ -2783,7 +2786,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'." java '("for" "if" "switch" "while" "catch" "synchronized") idl nil pike '("for" "if" "switch" "while" "foreach") - awk '("for" "if" "while")) + awk '("for" "if" "switch" "while")) (c-lang-defconst c-block-stmt-2-key ;; Regexp matching the start of any statement followed by a paren sexp @@ -2822,6 +2825,7 @@ Keywords here should also be in `c-block-stmt-1-kwds'." (c-lang-defconst c-simple-stmt-kwds "Statement keywords followed by an expression or nothing." t '("break" "continue" "goto" "return") + c++ '("break" "continue" "goto" "return" "co_return") objc '("break" "continue" "goto" "return" "@throw") ;; Note: `goto' is not valid in Java, but the keyword is still reserved. java '("break" "continue" "goto" "return" "throw") @@ -2862,8 +2866,7 @@ nevertheless contains a list separated with `;' and not `,'." (c-lang-defconst c-case-kwds "The keyword(s) which introduce a \"case\" like construct. This construct is \"<keyword> <expression> :\"." - t '("case") - awk nil) + t '("case")) (c-lang-defconst c-case-kwds-regexp ;; Adorned regexp matching any "case"-like keyword. @@ -2895,7 +2898,8 @@ This construct is \"<keyword> <expression> :\"." c++ (append '("nullptr") (c-lang-const c-constant-kwds c)) - objc '("nil" "Nil" "YES" "NO" "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER") + objc '("nil" "Nil" "YES" "NO" "IBAction" "IBOutlet" + "NS_DURING" "NS_HANDLER" "NS_ENDHANDLER") idl '("TRUE" "FALSE") java '("true" "false" "null") ; technically "literals", not keywords pike '("UNDEFINED")) ;; Not a keyword, but practically works as one. @@ -3030,7 +3034,14 @@ Note that Java specific rules are currently applied to tell this from ;; can start a declaration.) "entity" "process" "service" "session" "storage")) - +(c-lang-defconst c-std-abbrev-keywords + "List of keywords which may need to cause electric indentation." + t '("else" "while") + c++ (append (c-lang-const c-std-abbrev-keywords) '("catch")) + java (append (c-lang-const c-std-abbrev-keywords) '("catch" "finally")) + idl nil) +(c-lang-defvar c-std-abbrev-keywords (c-lang-const c-std-abbrev-keywords)) + ;;; Constants built from keywords. ;; Note: No `*-kwds' language constants may be defined below this point. @@ -3405,8 +3416,14 @@ regexp should match \"(\" if parentheses are valid in declarators. The end of the first submatch is taken as the end of the operator. Identifier syntax is in effect when this is matched (see `c-identifier-syntax-table')." - t (if (c-lang-const c-type-modifier-kwds) - (concat (regexp-opt (c-lang-const c-type-modifier-kwds) t) "\\>") + t (if (or (c-lang-const c-type-modifier-kwds) (c-lang-const c-modifier-kwds)) + (concat + (regexp-opt (c--delete-duplicates + (append (c-lang-const c-type-modifier-kwds) + (c-lang-const c-modifier-kwds)) + :test 'string-equal) + t) + "\\>") ;; Default to a regexp that never matches. regexp-unmatchable) ;; Check that there's no "=" afterwards to avoid matching tokens diff --git a/lisp/progmodes/cc-mode.el b/lisp/progmodes/cc-mode.el index 066bec60091..81bcd101fe4 100644 --- a/lisp/progmodes/cc-mode.el +++ b/lisp/progmodes/cc-mode.el @@ -278,6 +278,29 @@ control). See \"cc-mode.el\" for more info." (setq defs (cdr defs))))) (put 'c-define-abbrev-table 'lisp-indent-function 1) +(defun c-populate-abbrev-table () + ;; Insert the standard keywords which may need electric indentation into the + ;; current mode's abbreviation table. + (let ((table (intern (concat (symbol-name major-mode) "-abbrev-table"))) + (defs c-std-abbrev-keywords) + ) + (unless (and (boundp table) + (abbrev-table-p (symbol-value table))) + (define-abbrev-table table nil)) + (setq local-abbrev-table (symbol-value table)) + (while defs + (unless (intern-soft (car defs) local-abbrev-table) ; Don't overwrite the + ; abbrev's use count. + (condition-case nil + (define-abbrev (symbol-value table) + (car defs) (car defs) + 'c-electric-continued-statement 0 t) + (wrong-number-of-arguments + (define-abbrev (symbol-value table) + (car defs) (car defs) + 'c-electric-continued-statement 0)))) + (setq defs (cdr defs))))) + (defun c-bind-special-erase-keys () ;; Only used in Emacs to bind C-c C-<delete> and C-c C-<backspace> ;; to the proper keys depending on `normal-erase-is-backspace'. @@ -535,6 +558,18 @@ preferably use the `c-mode-menu' language constant directly." ;; and `after-change-functions'. Note that this variable is not set when ;; `c-before-change' is invoked by a change to text properties. +(defvar c-min-syn-tab-mkr nil) +;; The minimum buffer position where there's a `c-fl-syn-tab' text property, +;; or nil if there aren't any. This is a marker, or nil if there's currently +;; no such text property. +(make-variable-buffer-local 'c-min-syn-tab-mkr) + +(defvar c-max-syn-tab-mkr nil) +;; The maximum buffer position plus 1 where there's a `c-fl-syn-tab' text +;; property, or nil if there aren't any. This is a marker, or nil if there's +;; currently no such text property. +(make-variable-buffer-local 'c-max-syn-tab-mkr) + (defun c-basic-common-init (mode default-style) "Do the necessary initialization for the syntax handling routines and the line breaking/filling code. Intended to be used by other @@ -550,6 +585,8 @@ that requires a literal mode spec at compile time." (setq c-buffer-is-cc-mode mode) + (c-populate-abbrev-table) + ;; these variables should always be buffer local; they do not affect ;; indentation style. (make-local-variable 'comment-start) @@ -606,6 +643,10 @@ that requires a literal mode spec at compile time." ;; Initialize the "brace stack" cache. (c-init-bs-cache) + ;; Keep track of where `c-fl-syn-tab' text properties are set. + (setq c-min-syn-tab-mkr nil) + (setq c-max-syn-tab-mkr nil) + (when (or c-recognize-<>-arglists (c-major-mode-is 'awk-mode) (c-major-mode-is '(java-mode c-mode c++-mode objc-mode pike-mode))) @@ -1207,52 +1248,94 @@ Note that the style variables are always made local to the buffer." (c-put-char-property (1- (point)) 'syntax-table '(15))) (t nil))))) -(defvar c-fl-syn-tab-region nil) - ;; Non-nil when a `c-restore-string-fences' is "in force". It's value is a - ;; cons of the BEG and END of the region currently "mirroring" the - ;; c-fl-syn-tab properties as syntax-table properties. +(defun c-put-syn-tab (pos value) + ;; Set both the syntax-table and the c-fl-syn-tab text properties at POS to + ;; VALUE (which should not be nil). + ;; `(let ((-pos- ,pos) + ;; (-value- ,value)) + (c-put-char-property pos 'syntax-table value) + (c-put-char-property pos 'c-fl-syn-tab value) + (cond + ((null c-min-syn-tab-mkr) + (setq c-min-syn-tab-mkr (copy-marker pos t))) + ((< pos c-min-syn-tab-mkr) + (move-marker c-min-syn-tab-mkr pos))) + (cond + ((null c-max-syn-tab-mkr) + (setq c-max-syn-tab-mkr (copy-marker (1+ pos) nil))) + ((>= pos c-max-syn-tab-mkr) + (move-marker c-max-syn-tab-mkr (1+ pos)))) + (c-truncate-lit-pos-cache pos)) + +(defun c-clear-syn-tab (pos) + ;; Remove both the 'syntax-table and `c-fl-syn-tab properties at POS. + (c-clear-char-property pos 'syntax-table) + (c-clear-char-property pos 'c-fl-syn-tab) + (when c-min-syn-tab-mkr + (if (and (eq pos (marker-position c-min-syn-tab-mkr)) + (eq (1+ pos) (marker-position c-max-syn-tab-mkr))) + (progn + (move-marker c-min-syn-tab-mkr nil) + (move-marker c-max-syn-tab-mkr nil) + (setq c-min-syn-tab-mkr nil c-max-syn-tab-mkr nil)) + (when (eq pos (marker-position c-min-syn-tab-mkr)) + (move-marker c-min-syn-tab-mkr + (if (c-get-char-property (1+ pos) 'c-fl-syn-tab) + (1+ pos) + (c-next-single-property-change + (1+ pos) 'c-fl-syn-tab nil c-max-syn-tab-mkr)))) + (when (eq (1+ pos) (marker-position c-max-syn-tab-mkr)) + (move-marker c-max-syn-tab-mkr + (if (c-get-char-property (1- pos) 'c-fl-syn-tab) + pos + (c-previous-single-property-change + pos 'c-fl-syn-tab nil (1+ c-min-syn-tab-mkr))))))) + (c-truncate-lit-pos-cache pos)) (defun c-clear-string-fences () - ;; Clear syntax-table text properties in the region defined by - ;; `c-cl-syn-tab-region' which are "mirrored" by c-fl-syn-tab text - ;; properties. However, any such " character which ends up not being + ;; Clear syntax-table text properties which are "mirrored" by c-fl-syn-tab + ;; text properties. However, any such " character which ends up not being ;; balanced by another " is left with a '(1) syntax-table property. - (when c-fl-syn-tab-region - (let ((beg (car c-fl-syn-tab-region)) - (end (cdr c-fl-syn-tab-region)) - s pos) - (setq pos beg) + (when + (and c-min-syn-tab-mkr c-max-syn-tab-mkr) + (let (s pos) + (setq pos c-min-syn-tab-mkr) (while (and - (< pos end) - (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (< pos end)) + (< pos c-max-syn-tab-mkr) + (setq pos (c-min-property-position pos + c-max-syn-tab-mkr + 'c-fl-syn-tab)) + (< pos c-max-syn-tab-mkr)) (c-clear-char-property pos 'syntax-table) (setq pos (1+ pos))) ;; Check we haven't left any unbalanced "s. (save-excursion - (setq pos beg) + (setq pos c-min-syn-tab-mkr) ;; Is there already an unbalanced " before BEG? - (setq pos (c-min-property-position pos end 'c-fl-syn-tab)) - (when (< pos end) (goto-char pos)) + (setq pos (c-min-property-position pos c-max-syn-tab-mkr + 'c-fl-syn-tab)) + (when (< pos c-max-syn-tab-mkr) + (goto-char pos)) (when (and (save-match-data (c-search-backward-char-property-with-value-on-char 'c-fl-syn-tab '(15) ?\" (max (- (point) 500) (point-min)))) (not (equal (c-get-char-property (point) 'syntax-table) '(1)))) (setq pos (1+ pos))) - (while (< pos end) + (while (< pos c-max-syn-tab-mkr) (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (when (< pos end) + (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) + (when (< pos c-max-syn-tab-mkr) (if (memq (char-after pos) c-string-delims) (progn ;; Step over the ". - (setq s (parse-partial-sexp pos end nil nil nil + (setq s (parse-partial-sexp pos c-max-syn-tab-mkr + nil nil nil 'syntax-table)) ;; Seek a (bogus) matching ". - (setq s (parse-partial-sexp (point) end nil nil s + (setq s (parse-partial-sexp (point) c-max-syn-tab-mkr + nil nil s 'syntax-table)) ;; When a bogus matching " is found, do nothing. ;; Otherwise mark the " with 'syntax-table '(1). @@ -1262,23 +1345,22 @@ Note that the style variables are always made local to the buffer." (c-get-char-property (1- (point)) 'c-fl-syn-tab)) (c-put-char-property pos 'syntax-table '(1))) (setq pos (point))) - (setq pos (1+ pos)))))) - (setq c-fl-syn-tab-region nil)))) - -(defun c-restore-string-fences (beg end) - ;; Restore any syntax-table text properties in the region (BEG END) which - ;; are "mirrored" by c-fl-syn-tab text properties. - (let ((pos beg)) - (while - (and - (< pos end) - (setq pos - (c-min-property-position pos end 'c-fl-syn-tab)) - (< pos end)) - (c-put-char-property pos 'syntax-table - (c-get-char-property pos 'c-fl-syn-tab)) - (setq pos (1+ pos))) - (setq c-fl-syn-tab-region (cons beg end)))) + (setq pos (1+ pos))))))))) + +(defun c-restore-string-fences () + ;; Restore any syntax-table text properties which are "mirrored" by + ;; c-fl-syn-tab text properties. + (when (and c-min-syn-tab-mkr c-max-syn-tab-mkr) + (let ((pos c-min-syn-tab-mkr)) + (while + (and + (< pos c-max-syn-tab-mkr) + (setq pos + (c-min-property-position pos c-max-syn-tab-mkr 'c-fl-syn-tab)) + (< pos c-max-syn-tab-mkr)) + (c-put-char-property pos 'syntax-table + (c-get-char-property pos 'c-fl-syn-tab)) + (setq pos (1+ pos)))))) (defvar c-bc-changed-stringiness nil) ;; Non-nil when, in a before-change function, the deletion of a range of text @@ -1406,7 +1488,7 @@ Note that the style variables are always made local to the buffer." ;; Move to end of logical line (as it will be after the change, or as it ;; was before unescaping a NL.) - (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) + (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) ;; We're at an EOLL or point-max. (if (equal (c-get-char-property (point) 'syntax-table) '(15)) (if (memq (char-after) '(?\n ?\r)) @@ -1514,7 +1596,7 @@ Note that the style variables are always made local to the buffer." (progn (goto-char (min (1+ end) ; 1+, in case a NL has become escaped. (point-max))) - (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" + (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t) (point)) c-new-END)) @@ -1595,7 +1677,7 @@ Note that the style variables are always made local to the buffer." (c-beginning-of-macro)))) (goto-char (1+ end)) ; After the \ ;; Search forward for EOLL - (setq lim (re-search-forward "\\(\\\\\\(.\\|\n\\)\\|[^\\\n\r]\\)*" + (setq lim (re-search-forward "\\(?:\\\\\\(?:.\\|\n\\)\\|[^\\\n\r]\\)*" nil t)) (goto-char (1+ end)) (when (c-search-forward-char-property-with-value-on-char @@ -1888,7 +1970,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (unwind-protect (progn - (c-restore-string-fences (point-min) (point-max)) + (c-restore-string-fences) (save-excursion ;; Are we inserting/deleting stuff in the middle of an ;; identifier? @@ -2018,7 +2100,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") (widen) (unwind-protect (progn - (c-restore-string-fences (point-min) (point-max)) + (c-restore-string-fences) (when (> end (point-max)) ;; Some emacsen might return positions past the end. This ;; has been observed in Emacs 20.7 when rereading a buffer @@ -2183,7 +2265,7 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") enclosing-attribute pos1) (unless lit-start (c-backward-syntactic-ws) - (when (setq enclosing-attribute (c-slow-enclosing-c++-attribute)) + (when (setq enclosing-attribute (c-enclosing-c++-attribute)) (goto-char (car enclosing-attribute))) ; Only happens in C++ Mode. (when (setq pos1 (c-on-identifier)) (goto-char pos1) @@ -2255,69 +2337,48 @@ Note that this is a strict tail, so won't match, e.g. \"0x....\".") ;; line was fouled up by context fontification. (save-restriction (widen) - (let (new-beg new-end new-region case-fold-search string-fence-beg lim) - ;; Check how far back we need to extend the region where we reapply the - ;; string fence syntax-table properties. These must be in place for the - ;; coming fontification operations. - (save-excursion - (goto-char (if c-in-after-change-fontification - (min beg c-new-BEG) - beg)) - (setq lim (max (- (point) 500) (point-min))) - (while + (let (new-beg new-end new-region case-fold-search) + (c-save-buffer-state nil + ;; Temporarily reapply the string fence syntax-table properties. + (unwind-protect (progn - (skip-chars-backward "^\"" lim) - (or (bobp) (backward-char)) - (save-excursion - (eq (logand (skip-chars-backward "\\\\") 1) 1)))) - (setq string-fence-beg - (cond ((c-get-char-property (point) 'c-fl-syn-tab) - (point)) - (c-in-after-change-fontification - c-new-BEG) - (t beg))) - (c-save-buffer-state nil - ;; Temporarily reapply the string fence syntax-table properties. - (c-with-extended-string-fences - string-fence-beg (if c-in-after-change-fontification - (max end c-new-END) - end) - - (if (and c-in-after-change-fontification - (< beg c-new-END) (> end c-new-BEG)) - ;; Region and the latest after-change fontification region overlap. - ;; Determine the upper and lower bounds of our adjusted region - ;; separately. - (progn - (if (<= beg c-new-BEG) - (setq c-in-after-change-fontification nil)) - (setq new-beg - (if (and (>= beg (c-point 'bol c-new-BEG)) - (<= beg c-new-BEG)) - ;; Either jit-lock has accepted `c-new-BEG', or has - ;; (probably) extended the change region spuriously - ;; to BOL, which position likely has a - ;; syntactically different position. To ensure - ;; correct fontification, we start at `c-new-BEG', - ;; assuming any characters to the left of - ;; `c-new-BEG' on the line do not require - ;; fontification. - c-new-BEG - (setq new-region (c-before-context-fl-expand-region beg end) - new-end (cdr new-region)) - (car new-region))) - (setq new-end - (if (and (>= end (c-point 'bol c-new-END)) - (<= end c-new-END)) - c-new-END - (or new-end - (cdr (c-before-context-fl-expand-region beg end)))))) - ;; Context (etc.) fontification. - (setq new-region (c-before-context-fl-expand-region beg end) - new-beg (car new-region) new-end (cdr new-region))) - ;; Finally invoke font lock's functionality. - (funcall (default-value 'font-lock-fontify-region-function) - new-beg new-end verbose))))))) + (c-restore-string-fences) + (if (and c-in-after-change-fontification + (< beg c-new-END) (> end c-new-BEG)) + ;; Region and the latest after-change fontification region overlap. + ;; Determine the upper and lower bounds of our adjusted region + ;; separately. + (progn + (if (<= beg c-new-BEG) + (setq c-in-after-change-fontification nil)) + (setq new-beg + (if (and (>= beg (c-point 'bol c-new-BEG)) + (<= beg c-new-BEG)) + ;; Either jit-lock has accepted `c-new-BEG', or has + ;; (probably) extended the change region spuriously + ;; to BOL, which position likely has a + ;; syntactically different position. To ensure + ;; correct fontification, we start at `c-new-BEG', + ;; assuming any characters to the left of + ;; `c-new-BEG' on the line do not require + ;; fontification. + c-new-BEG + (setq new-region (c-before-context-fl-expand-region beg end) + new-end (cdr new-region)) + (car new-region))) + (setq new-end + (if (and (>= end (c-point 'bol c-new-END)) + (<= end c-new-END)) + c-new-END + (or new-end + (cdr (c-before-context-fl-expand-region beg end)))))) + ;; Context (etc.) fontification. + (setq new-region (c-before-context-fl-expand-region beg end) + new-beg (car new-region) new-end (cdr new-region))) + ;; Finally invoke font lock's functionality. + (funcall (default-value 'font-lock-fontify-region-function) + new-beg new-end verbose)) + (c-clear-string-fences)))))) (defun c-after-font-lock-init () ;; Put on `font-lock-mode-hook'. This function ensures our after-change @@ -2444,11 +2505,6 @@ opening \" and the next unescaped end of line." (funcall (c-lang-const c-make-mode-syntax-table c)) "Syntax table used in c-mode buffers.") -(c-define-abbrev-table 'c-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in c-mode buffers.") - (defvar c-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2521,13 +2577,21 @@ Key bindings: (defconst c-or-c++-mode--regexp (eval-when-compile - (let ((id "[a-zA-Z0-9_]+") (ws "[ \t\r]+") (ws-maybe "[ \t\r]*")) + (let ((id "[a-zA-Z_][a-zA-Z0-9_]*") (ws "[ \t]+") (ws-maybe "[ \t]*") + (headers '("string" "string_view" "iostream" "map" "unordered_map" + "set" "unordered_set" "vector" "tuple"))) (concat "^" ws-maybe "\\(?:" - "using" ws "\\(?:namespace" ws "std;\\|std::\\)" - "\\|" "namespace" "\\(:?" ws id "\\)?" ws-maybe "{" - "\\|" "class" ws id ws-maybe "[:{\n]" - "\\|" "template" ws-maybe "<.*>" - "\\|" "#include" ws-maybe "<\\(?:string\\|iostream\\|map\\)>" + "using" ws "\\(?:namespace" ws + "\\|" id "::" + "\\|" id ws-maybe "=\\)" + "\\|" "\\(?:inline" ws "\\)?namespace" + "\\(:?" ws "\\(?:" id "::\\)*" id "\\)?" ws-maybe "{" + "\\|" "class" ws id + "\\(?:" ws "final" "\\)?" ws-maybe "[:{;\n]" + "\\|" "struct" ws id "\\(?:" ws "final" ws-maybe "[:{\n]" + "\\|" ws-maybe ":\\)" + "\\|" "template" ws-maybe "<.*?>" + "\\|" "#include" ws-maybe "<" (regexp-opt headers) ">" "\\)"))) "A regexp applied to C header files to check if they are really C++.") @@ -2543,6 +2607,7 @@ should be used. This function attempts to use file contents to determine whether the code is C or C++ and based on that chooses whether to enable `c-mode' or `c++-mode'." + (interactive) (if (save-excursion (save-restriction (save-match-data @@ -2560,12 +2625,6 @@ the code is C or C++ and based on that chooses whether to enable (funcall (c-lang-const c-make-mode-syntax-table c++)) "Syntax table used in c++-mode buffers.") -(c-define-abbrev-table 'c++-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0) - ("catch" "catch" c-electric-continued-statement 0)) - "Abbreviation table used in c++-mode buffers.") - (defvar c++-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2614,11 +2673,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table objc)) "Syntax table used in objc-mode buffers.") -(c-define-abbrev-table 'objc-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in objc-mode buffers.") - (defvar objc-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2665,13 +2719,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table java)) "Syntax table used in java-mode buffers.") -(c-define-abbrev-table 'java-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0) - ("catch" "catch" c-electric-continued-statement 0) - ("finally" "finally" c-electric-continued-statement 0)) - "Abbreviation table used in java-mode buffers.") - (defvar java-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2683,7 +2730,7 @@ Key bindings: ;; since it's practically impossible to write a regexp that reliably ;; matches such a construct. Other tools are necessary. (defconst c-Java-defun-prompt-regexp - "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*[][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") + "^[ \t]*\\(\\(\\(public\\|protected\\|private\\|const\\|abstract\\|synchronized\\|final\\|static\\|threadsafe\\|transient\\|native\\|volatile\\)\\s-+\\)*\\(\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]+\\|[[a-zA-Z]\\)\\s-*\\)\\s-+\\)\\)?\\(\\([[a-zA-Z][][_$.a-zA-Z0-9]*\\s-+\\)\\s-*\\)?\\([_a-zA-Z][^][ \t:;.,{}()\^?=]*\\|\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)\\)\\s-*\\(([^);{}]*)\\)?\\([] \t]*\\)\\(\\s-*\\<throws\\>\\s-*\\(\\([_$a-zA-Z][_$.a-zA-Z0-9]*\\)[, \t\n\r\f\v]*\\)+\\)?\\s-*") (easy-menu-define c-java-menu java-mode-map "Java Mode Commands" (cons "Java" (c-lang-const c-mode-menu java))) @@ -2722,9 +2769,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table idl)) "Syntax table used in idl-mode buffers.") -(c-define-abbrev-table 'idl-mode-abbrev-table nil - "Abbreviation table used in idl-mode buffers.") - (defvar idl-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2767,11 +2811,6 @@ Key bindings: (funcall (c-lang-const c-make-mode-syntax-table pike)) "Syntax table used in pike-mode buffers.") -(c-define-abbrev-table 'pike-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in pike-mode buffers.") - (defvar pike-mode-map (let ((map (c-make-inherited-keymap))) map) @@ -2819,11 +2858,6 @@ Key bindings: ;;;###autoload (add-to-list 'interpreter-mode-alist '("nawk" . awk-mode)) ;;;###autoload (add-to-list 'interpreter-mode-alist '("gawk" . awk-mode)) -(c-define-abbrev-table 'awk-mode-abbrev-table - '(("else" "else" c-electric-continued-statement 0) - ("while" "while" c-electric-continued-statement 0)) - "Abbreviation table used in awk-mode buffers.") - (defvar awk-mode-map (let ((map (c-make-inherited-keymap))) map) diff --git a/lisp/progmodes/cc-vars.el b/lisp/progmodes/cc-vars.el index 556ff6059f1..b885f6ae1d8 100644 --- a/lisp/progmodes/cc-vars.el +++ b/lisp/progmodes/cc-vars.el @@ -576,6 +576,7 @@ comment styles: javadoc -- Javadoc style for \"/** ... */\" comments (default in Java mode). autodoc -- Pike autodoc style for \"//! ...\" comments (default in Pike mode). gtkdoc -- GtkDoc style for \"/** ... **/\" comments (default in C and C++ modes). + doxygen -- Doxygen style. The value may also be a list of doc comment styles, in which case all of them are recognized simultaneously (presumably with markup cues @@ -1649,6 +1650,15 @@ white space either before or after the operator, but not both." :type 'boolean :group 'c) +(defcustom c-cpp-indent-to-body-directives '("pragma") + "Preprocessor directives which will be indented as statements. + +A list of Preprocessor directives which when reindented, or newly +typed in, will cause the \"#\" introducing the directive to be +indented as a statement." + :type '(repeat string) + :group 'c) + ;; Initialize the next two to a regexp which never matches. (defvar c-noise-macro-with-parens-name-re regexp-unmatchable) (make-variable-buffer-local 'c-noise-macro-with-parens-name-re) diff --git a/lisp/progmodes/cfengine.el b/lisp/progmodes/cfengine.el index 9ddb2ab2bbb..a8fe485b702 100644 --- a/lisp/progmodes/cfengine.el +++ b/lisp/progmodes/cfengine.el @@ -1294,10 +1294,10 @@ Calls `cfengine-cf-promises' with \"-s json\"." 'symbols)) syntax))) -(defun cfengine3-documentation-function () +(defun cfengine3-documentation-function (&rest _ignored) "Document CFengine 3 functions around point. -Intended as the value of `eldoc-documentation-function', which see. -Use it by enabling `eldoc-mode'." +Intended as the value of `eldoc-documentation-functions', which +see. Use it by enabling `eldoc-mode'." (let ((fdef (cfengine3--current-function))) (when fdef (cfengine3-format-function-docstring fdef)))) @@ -1322,7 +1322,7 @@ Use it by enabling `eldoc-mode'." (set (make-local-variable 'parens-require-spaces) nil) (set (make-local-variable 'comment-start) "# ") (set (make-local-variable 'comment-start-skip) - "\\(\\(?:^\\|[^\\\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*") + "\\(\\(?:^\\|[^\\\n]\\)\\(?:\\\\\\\\\\)*\\)#+[ \t]*") ;; Like Lisp mode. Without this, we lose with, say, ;; `backward-up-list' when there's an unbalanced quote in a ;; preceding comment. @@ -1390,12 +1390,8 @@ to the action header." (when buffer-file-name (shell-quote-argument buffer-file-name))))) - ;; For emacs < 25.1 where `eldoc-documentation-function' defaults to - ;; nil. - (or eldoc-documentation-function - (setq-local eldoc-documentation-function #'ignore)) - (add-function :before-until (local 'eldoc-documentation-function) - #'cfengine3-documentation-function) + (add-hook 'eldoc-documentation-functions + #'cfengine3-documentation-function nil t) (add-hook 'completion-at-point-functions #'cfengine3-completion-function nil t) diff --git a/lisp/progmodes/cl-font-lock.el b/lisp/progmodes/cl-font-lock.el new file mode 100644 index 00000000000..7ef43fd4490 --- /dev/null +++ b/lisp/progmodes/cl-font-lock.el @@ -0,0 +1,289 @@ +;;; cl-font-lock.el --- Pretty Common Lisp font locking -*- lexical-binding: t; -*- +;; Copyright (C) 2019-2020 Free Software Foundation, Inc. + +;; Author: Yue Daian <sheepduke@gmail.com> +;; Maintainer: Spenser Truex <web@spensertruex.com> +;; Created: 2019-06-16 +;; Old-Version: 0.3.0 +;; Package-Requires: ((emacs "24.5")) +;; Keywords: lisp wp files convenience +;; URL: https://github.com/cl-font-lock/cl-font-lock +;; Homepage: https://github.com/cl-font-lock/cl-font-lock + +;; This file is part of GNU Emacs + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. + +;;; Commentary: + +;; Highlight all the symbols in the Common Lisp ANSI Standard. +;; Adds font-lock regexes to lisp-mode. + +;;;; Todo: + +;; - Integrate better into `lisp-mode' (e.g. enable it by default). +;; - Distinguish functions from macros like `pushnew'. + +;;; Code: + +;; The list of built-in functions and variables was actually not +;; extracted from the standard, but from SBCL with the following +;; (Common Lisp) code: + +;; (defvar *functions* nil) +;; (defvar *symbols* nil) +;; (defvar *types* nil) + +;; (let ((pack (find-package :common-lisp))) +;; (do-all-symbols (sym) +;; (cond +;; ((not (eql pack (symbol-package sym))) nil) +;; ((fboundp sym) (pushnew sym *functions*)) +;; ((find-class sym nil) (pushnew sym *types*)) +;; (t (pushnew sym *symbols*))))) + + +(defvar cl-font-lock-built-in--functions + '("+" "-" "/" "/=" "<" "<=" "=" ">" ">=" "*" "1-" "1+" "abs" "acons" "acos" + "acosh" "add-method" "adjoin" "adjustable-array-p" "adjust-array" + "allocate-instance" "alpha-char-p" "alphanumericp" "and" "append" "apply" + "apropos" "apropos-list" "aref" "arithmetic-error-operands" + "arithmetic-error-operation" "array-dimension" "array-dimensions" + "array-displacement" "array-element-type" "array-has-fill-pointer-p" + "array-in-bounds-p" "arrayp" "array-rank" "array-row-major-index" + "array-total-size" "ash" "asin" "asinh" "assoc" "assoc-if" "assoc-if-not" + "atan" "atanh" "atom" "bit" "bit-and" "bit-andc1" "bit-andc2" "bit-eqv" + "bit-ior" "bit-nand" "bit-nor" "bit-not" "bit-orc1" "bit-orc2" + "bit-vector-p" "bit-xor" "boole" "both-case-p" "boundp" + "broadcast-stream-streams" "butlast" "byte" "byte-position" "byte-size" + "call-method" "call-next-method" "car" "catch" "cdr" "ceiling" + "cell-error-name" "change-class" "char" "char/=" "char<" "char<=" "char=" + "char>" "char>=" "character" "characterp" "char-code" "char-downcase" + "char-equal" "char-greaterp" "char-int" "char-lessp" "char-name" + "char-not-equal" "char-not-greaterp" "char-not-lessp" "char-upcase" "cis" + "class-name" "class-of" "clear-input" "clear-output" "close" "clrhash" + "code-char" "coerce" "compile" "compiled-function-p" "compile-file" + "compile-file-pathname" "compiler-macro-function" "complement" "complex" + "complexp" "compute-applicable-methods" "compute-restarts" "concatenate" + "concatenated-stream-streams" "conjugate" "cons" "consp" "constantly" + "constantp" "continue" "copy-alist" "copy-list" "copy-pprint-dispatch" + "copy-readtable" "copy-seq" "copy-structure" "copy-symbol" "copy-tree" + "cos" "cosh" "count" "count-if" "count-if-not" "decf" "decode-float" + "decode-universal-time" "delete" "delete-duplicates" "delete-file" + "delete-if" "delete-if-not" "delete-package" "denominator" "deposit-field" + "describe" "describe-object" "digit-char" "digit-char-p" "directory" + "directory-namestring" "disassemble" "do-all-symbols" "documentation" + "do-external-symbols" "do-symbols" "dpb" "dribble" + "echo-stream-input-stream" "echo-stream-output-stream" "ed" "eighth" "elt" + "encode-universal-time" "endp" "enough-namestring" + "ensure-directories-exist" "ensure-generic-function" "eq" "eql" "equal" + "equalp" "eval" "evenp" "every" "exp" "export" "expt" "fboundp" "fceiling" + "fdefinition" "ffloor" "fifth" "file-author" "file-error-pathname" + "file-length" "file-namestring" "file-position" "file-string-length" + "file-write-date" "fill" "fill-pointer" "find" "find-all-symbols" + "find-class" "find-if" "find-if-not" "find-method" "find-package" + "find-restart" "find-symbol" "finish-output" "first" "float" "float-digits" + "floatp" "float-precision" "float-radix" "float-sign" "floor" "fmakunbound" + "force-output" "format" "formatter" "fourth" "fresh-line" "fround" + "ftruncate" "funcall" "function" "function-keywords" + "function-lambda-expression" "functionp" "gcd" "gensym" "gentemp" "get" + "get-decoded-time" "get-dispatch-macro-character" "getf" "gethash" + "get-internal-real-time" "get-internal-run-time" "get-macro-character" + "get-output-stream-string" "get-properties" "get-setf-expansion" + "get-universal-time" "graphic-char-p" "hash-table-count" "hash-table-p" + "hash-table-rehash-size" "hash-table-rehash-threshold" "hash-table-size" + "hash-table-test" "host-namestring" "identity" "imagpart" "import" "incf" + "initialize-instance" "input-stream-p" "inspect" "integer-decode-float" + "integer-length" "integerp" "interactive-stream-p" "intern" "intersection" + "invalid-method-error" "invoke-debugger" "invoke-restart" + "invoke-restart-interactively" "isqrt" "keywordp" "last" "lcm" "ldb" + "ldb-test" "ldiff" "length" "lisp-implementation-type" + "lisp-implementation-version" "list" "list\\*" "list-all-packages" "listen" + "list-length" "listp" "load" "load-logical-pathname-translations" + "load-time-value" "log" "logand" "logandc1" "logandc2" "logbitp" "logcount" + "logeqv" "logical-pathname" "logical-pathname-translations" "logior" + "lognand" "lognor" "lognot" "logorc1" "logorc2" "logtest" "logxor" + "long-site-name" "loop-finish" "lower-case-p" "machine-instance" + "machine-type" "machine-version" "macroexpand" "macroexpand-1" + "macro-function" "make-array" "make-array" "make-broadcast-stream" + "make-concatenated-stream" "make-condition" "make-dispatch-macro-character" + "make-echo-stream" "make-hash-table" "make-instance" + "make-instances-obsolete" "make-list" "make-load-form" + "make-load-form-saving-slots" "make-method" "make-package" "make-pathname" + "make-random-state" "make-sequence" "make-string" + "make-string-input-stream" "make-string-output-stream" "make-symbol" + "make-synonym-stream" "make-two-way-stream" "makunbound" "map" "mapc" + "mapcan" "mapcar" "mapcon" "maphash" "map-into" "mapl" "maplist" + "mask-field" "max" "member" "member-if" "member-if-not" "merge" + "merge-pathnames" "method-combination-error" "method-qualifiers" "min" + "minusp" "mismatch" "mod" "muffle-warning" "multiple-value-call" + "multiple-value-list" "multiple-value-setq" "name-char" "namestring" + "nbutlast" "nconc" "next-method-p" "nintersection" "ninth" + "no-applicable-method" "no-next-method" "not" "notany" "notevery" "nreconc" + "nreverse" "nset-difference" "nset-exclusive-or" "nstring-capitalize" + "nstring-downcase" "nstring-upcase" "nsublis" "nsubst" "nsubst-if" + "nsubst-if-not" "nsubstitute" "nsubstitute-if" "nsubstitute-if-not" "nth" + "nthcdr" "nth-value" "null" "numberp" "numerator" "nunion" "oddp" "open" + "open-stream-p" "or" "output-stream-p" "package-error-package" + "package-name" "package-nicknames" "packagep" "package-shadowing-symbols" + "package-used-by-list" "package-use-list" "pairlis" "parse-integer" + "parse-namestring" "pathname" "pathname-device" "pathname-directory" + "pathname-host" "pathname-match-p" "pathname-name" "pathnamep" + "pathname-type" "pathname-version" "peek-char" "phase" "plusp" "pop" + "position" "position-if" "position-if-not" "pprint" "pprint-dispatch" + "pprint-exit-if-list-exhausted" "pprint-fill" "pprint-indent" + "pprint-linear" "pprint-logical-block" "pprint-newline" "pprint-pop" + "pprint-tab" "pprint-tabular" "prin1" "prin1-to-string" "princ" + "princ-to-string" "print" "print-not-readable-object" "print-object" + "print-unreadable-object" "probe-file" "provide" "psetf" "psetq" "push" + "pushnew" "quote" "random" "random-state-p" "rassoc" "rassoc-if" + "rassoc-if-not" "rational" "rationalize" "rationalp" "read" "read-byte" + "read-char" "read-char-no-hang" "read-delimited-list" "read-from-string" + "read-line" "read-preserving-whitespace" "read-sequence" "readtable-case" + "readtablep" "realp" "realpart" "reduce" "reinitialize-instance" "rem" + "remf" "remhash" "remove" "remove-duplicates" "remove-if" "remove-if-not" + "remove-method" "remprop" "rename-file" "rename-package" "replace" + "require" "rest" "restart-name" "revappend" "reverse" "room" "rotatef" + "round" "row-major-aref" "rplaca" "rplacd" "sbit" "scale-float" "schar" + "search" "second" "set" "set-difference" "set-dispatch-macro-character" + "set-exclusive-or" "setf" "set-macro-character" "set-pprint-dispatch" + "setq" "set-syntax-from-char" "seventh" "shadow" "shadowing-import" + "shared-initialize" "shiftf" "short-site-name" "signum" + "simple-bit-vector-p" "simple-condition-format-arguments" + "simple-condition-format-control" "simple-string-p" "simple-vector-p" "sin" + "sinh" "sixth" "sleep" "slot-boundp" "slot-exists-p" "slot-makunbound" + "slot-missing" "slot-unbound" "slot-value" "software-type" + "software-version" "some" "sort" "special-operator-p" "sqrt" "stable-sort" + "standard-char-p" "step" "store-value" "stream-element-type" + "stream-error-stream" "stream-external-format" "streamp" "string" + "string/=" "string<" "string<=" "string=" "string>" "string>=" + "string-capitalize" "string-downcase" "string-equal" "string-greaterp" + "string-left-trim" "string-lessp" "string-not-equal" "string-not-greaterp" + "string-not-lessp" "stringp" "string-right-trim" "string-trim" + "string-upcase" "sublis" "subseq" "subsetp" "subst" "subst-if" + "subst-if-not" "substitute" "substitute-if" "substitute-if-not" "subtypep" + "svref" "sxhash" "symbol-function" "symbol-name" "symbolp" "symbol-package" + "symbol-plist" "symbol-value" "synonym-stream-symbol" "tailp" "tan" "tanh" + "tenth" "terpri" "third" "throw" "time" "trace" + "translate-logical-pathname" "translate-pathname" "tree-equal" "truename" + "truncate" "two-way-stream-input-stream" "two-way-stream-output-stream" + "type-error-datum" "type-error-expected-type" "type-of" "typep" + "unbound-slot-instance" "unexport" "unintern" "union" "unread-char" + "untrace" "unuse-package" "update-instance-for-different-class" + "update-instance-for-redefined-class" "upgraded-array-element-type" + "upgraded-complex-part-type" "upper-case-p" "use-package" + "user-homedir-pathname" "use-value" "values" "values-list" "vector" + "vectorp" "vector-pop" "vector-push" "vector-push-extend" "wild-pathname-p" + "write" "write-byte" "write-char" "write-line" "write-sequence" + "write-string" "write-to-string" "yes-or-no-p" "y-or-n-p" "zerop")) + +(defvar cl-font-lock-built-in--variables + '("//" "///" "\\*load-pathname\\*" "\\*print-pprint-dispatch\\*" + "\\*break-on-signals\\*" "\\*load-print\\*" "\\*print-pprint-dispatch\\*" + "\\*break-on-signals\\*" "\\*load-truename\\*" "\\*print-pretty\\*" + "\\*load-verbose\\*" "\\*print-radix\\*" "\\*compile-file-pathname\\*" + "\\*macroexpand-hook\\*" "\\*print-readably\\*" + "\\*compile-file-pathname\\*" "\\*modules\\*" "\\*print-right-margin\\*" + "\\*compile-file-truename\\*" "\\*package\\*" "\\*print-right-margin\\*" + "\\*compile-file-truename\\*" "\\*print-array\\*" "\\*query-io\\*" + "\\*compile-print\\*" "\\*print-base\\*" "\\*random-state\\*" + "\\*compile-verbose\\*" "\\*default-pathname-defaults\\*" + "\\*print-length\\*" "\\*readtable\\*" "\\*error-output\\*" + "\\*print-level\\*" "\\*standard-input\\*" "\\*print-case\\*" + "\\*read-base\\*" "\\*compile-verbose\\*" "\\*print-circle\\*" + "\\*print-lines\\*" "\\*standard-output\\*" "\\*features\\*" + "\\*print-miser-width\\*" "\\*read-default-float-format\\*" + "\\*debug-io\\*" "\\*print-escape\\*" "\\*read-eval\\*" + "\\*debugger-hook\\*" "\\*print-gensym\\*" "\\*read-suppress\\*" + "\\*terminal-io\\*" "\\*gensym-counter\\*" "\\*print-miser-width\\*" + "\\*trace-output\\*" "array-dimension-limit" "array-rank-limit" + "array-total-size-limit" "boole-1" "boole-2" "boole-and" "boole-andc1" + "boole-andc2" "boole-c1" "boole-c2" "boole-clr" "boole-eqv" "boole-ior" + "boole-nand" "boole-nor" "boole-orc1" "boole-orc2" "boole-set" "boole-xor" + "call-arguments-limit" "char-code-limit" "double-float-epsilon" + "double-float-negative-epsilon" "internal-time-units-per-second" + "lambda-list-keywords" "lambda-parameters-limit" + "least-negative-double-float" "least-negative-long-float" + "least-negative-normalized-double-float" + "least-negative-normalized-long-float" + "least-negative-normalized-short-float" + "least-negative-normalized-single-float" "least-negative-short-float" + "least-negative-single-float" "least-positive-double-float" + "least-positive-long-float" "least-positive-normalized-double-float" + "least-positive-normalized-long-float" + "least-positive-normalized-short-float" + "least-positive-normalized-single-float" "least-positive-short-float" + "least-positive-single-float" "long-float-epsilon" + "long-float-negative-epsilon" "most-negative-double-float" + "most-negative-fixnum" "most-negative-long-float" + "most-negative-short-float" "most-negative-single-float" + "most-positive-double-float" "most-positive-fixnum" + "most-positive-long-float" "most-positive-short-float" + "most-positive-single-float" "multiple-values-limit" "short-float-epsilon" + "short-float-negative-epsilon" "single-float-epsilon" + "single-float-negative-epsilon" "pi")) + +(defvar cl-font-lock-built-in--types + '("arithmetic-error" "array" "base-char" "base-string" "bignum" "bit-vector" + "boolean" "broadcast-stream" "built-in-class" "cell-error" "class" + "compiled-function" "concatenated-stream" "condition" "control-error" + "division-by-zero" "double-float" "echo-stream" "end-of-file" + "extended-char" "file-error" "file-stream" "fixnum" + "floating-point-inexact" "floating-point-invalid-operation" + "floating-point-overflow" "floating-point-underflow" "generic-function" + "hash-table" "integer" "keyword" "long-float" "method" "method-combination" + "number" "package" "package-error" "parse-error" "print-not-readable" + "program-error" "random-state" "ratio" "reader-error" "readtable" "real" + "restart" "sequence" "serious-condition" "short-float" "signed-byte" + "simple-array" "simple-base-string" "simple-bit-vector" "simple-condition" + "simple-error" "simple-string" "simple-type-error" "simple-vector" + "simple-warning" "single-float" "standard-char" "standard-class" + "standard-generic-function" "standard-method" "standard-object" + "storage-condition" "stream" "stream-error" "string-stream" + "structure-class" "structure-object" "style-warning" "symbol" + "synonym-stream" "two-way-stream" "type-error" "unbound-slot" + "unbound-variable" "undefined-function" "unsigned-byte" "warning")) + +(defvar cl-font-lock-built-in--symbols + '("compilation-speed" "compiler-macro" "debug" "declaration" "dynamic-extent" + "ftype" "ignorable" "ignore" "inline" "notinline" "optimize" "otherwise" + "safety" "satisfies" "space" "special" "speed" "structure" "type")) + +(defvar cl-font-lock--character-names + '("newline" "space" "rubout" "page" "tab" "backspace" "return" "linefeed")) + +(defvar cl-font-lock-built-in-keywords + (mapcar (lambda (s) + `(,(regexp-opt (symbol-value (car s)) 'symbols) + . ,(cdr s))) + '((cl-font-lock-built-in--functions . font-lock-function-name-face) + (cl-font-lock-built-in--variables . font-lock-variable-name-face) + (cl-font-lock-built-in--types . font-lock-type-face) + (cl-font-lock-built-in--symbols . font-lock-builtin-face) + (cl-font-lock--character-names . font-lock-variable-name-face)))) + +;;;###autoload +(define-minor-mode cl-font-lock-built-in-mode + "Highlight built-in functions, variables, and types in `lisp-mode'." + :global t + (funcall + (if cl-font-lock-built-in-mode + #'font-lock-add-keywords + #'font-lock-remove-keywords) + 'lisp-mode + cl-font-lock-built-in-keywords)) + +(provide 'cl-font-lock) + +;;; cl-font-lock.el ends here diff --git a/lisp/progmodes/compile.el b/lisp/progmodes/compile.el index 455f181f501..a76a3c44a35 100644 --- a/lisp/progmodes/compile.el +++ b/lisp/progmodes/compile.el @@ -265,6 +265,20 @@ of[ \t]+\"?\\([a-zA-Z]?:?[^\":\n]+\\)\"?:" 3 2 nil (1)) (java "^\\(?:[ \t]+at \\|==[0-9]+== +\\(?:at\\|b\\(y\\)\\)\\).+(\\([^()\n]+\\):\\([0-9]+\\))$" 2 3 nil (1)) + (javac + ,(concat + ;; line1 + "^\\(\\(?:[A-Za-z]:\\)?[^:\n]+\\):" ;file + "\\([0-9]+\\): " ;line + "\\(warning: \\)?.*\n" ;type (optional) and message + ;; line2: source line containing error + ".*\n" + ;; line3: single "^" under error position in line2 + " *\\^$") + 1 2 + ,(lambda () (1- (current-column))) + (3)) + (jikes-file "^\\(?:Found\\|Issued\\) .* compiling \"\\(.+\\)\":$" 1 nil nil 0) @@ -646,6 +660,16 @@ matched file names, and weeding out false positives." :link `(file-link :tag "example file" ,(expand-file-name "compilation.txt" data-directory))) +(defvar compilation-error-case-fold-search nil + "If non-nil, use case-insensitive matching of compilation errors +by the regexps of `compilation-error-regexp-alist' and +`compilation-error-regexp-alist-alist'. +If nil, matching is case-sensitive. + +This variable should only be set for backward compatibility as a temporary +measure. The proper solution is to use a regexp that matches the +messages without case-folding.") + ;;;###autoload(put 'compilation-directory 'safe-local-variable 'stringp) (defvar compilation-directory nil "Directory to restore to when doing `recompile'.") @@ -1435,7 +1459,8 @@ to `compilation-error-regexp-alist' if RULES is nil." (if (symbolp item) (setq item (cdr (assq item compilation-error-regexp-alist-alist)))) - (let ((file (nth 1 item)) + (let ((case-fold-search compilation-error-case-fold-search) + (file (nth 1 item)) (line (nth 2 item)) (col (nth 3 item)) (type (nth 4 item)) @@ -1455,9 +1480,15 @@ to `compilation-error-regexp-alist' if RULES is nil." nil) ;; Not anchored or anchored but already allows empty spaces. (t (setq pat (concat "^\\(?: \\)?" (substring pat 1))))) - (if (consp file) (setq fmt (cdr file) file (car file))) - (if (consp line) (setq end-line (cdr line) line (car line))) - (if (consp col) (setq end-col (cdr col) col (car col))) + (if (and (consp file) (not (functionp file))) + (setq fmt (cdr file) + file (car file))) + (if (and (consp line) (not (functionp line))) + (setq end-line (cdr line) + line (car line))) + (if (and (consp col) (not (functionp col))) + (setq end-col (cdr col) + col (car col))) (unless (or (null (nth 5 item)) (integerp (nth 5 item))) (error "HYPERLINK should be an integer: %s" (nth 5 item))) diff --git a/lisp/progmodes/cperl-mode.el b/lisp/progmodes/cperl-mode.el index 5fee2df5863..cdbb59a5add 100644 --- a/lisp/progmodes/cperl-mode.el +++ b/lisp/progmodes/cperl-mode.el @@ -1306,7 +1306,7 @@ the last)." cperl-maybe-white-and-comment-rex ; whitespace-comments "\\(\\sw\\|_\\)+" ; attr-name ;; attr-arg (1 level of internal parens allowed!) - "\\((\\(\\\\.\\|[^\\\\()]\\|([^\\\\()]*)\\)*)\\)?" + "\\((\\(\\\\.\\|[^\\()]\\|([^\\()]*)\\)*)\\)?" "\\(" ; optional : (XXX allows trailing???) cperl-maybe-white-and-comment-rex ; whitespace-comments ":\\)?" @@ -1406,7 +1406,7 @@ the last)." (defvar cperl-font-locking nil) ;; NB as it stands the code in cperl-mode assumes this only has one -;; element. If XEmacs 19 support were dropped, this could all be simplified. +;; element. Since XEmacs 19 support has been dropped, this could all be simplified. (defvar cperl-compilation-error-regexp-alist ;; This look like a paranoiac regexp: could anybody find a better one? (which WORKS). '(("^[^\n]* \\(file\\|at\\) \\([^ \t\n]+\\) [^\n]*line \\([0-9]+\\)[\\., \n]" @@ -5659,16 +5659,16 @@ indentation and initial hashes. Behaves usually outside of comment." '("^[ \t]*format[ \t]+\\([a-zA-Z_][a-zA-Z_0-9:]*\\)[ \t]*=[ \t]*$" 1 font-lock-function-name-face) (cond ((featurep 'font-lock-extra) - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) (0 '(restart 2 t)))) ; To highlight $a{bc}{ef} (font-lock-anchored - '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" (2 font-lock-string-face t) ("\\=[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" nil nil (1 font-lock-string-face t)))) - (t '("\\([]}\\\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" + (t '("\\([]}\\%@>*&]\\|\\$[a-zA-Z0-9_:]*\\)[ \t]*{[ \t]*\\(-?[a-zA-Z0-9_:]+\\)[ \t]*}" 2 font-lock-string-face t))) '("[[ \t{,(]\\(-?[a-zA-Z0-9_:]+\\)[ \t]*=>" 1 font-lock-string-face t) diff --git a/lisp/progmodes/cwarn.el b/lisp/progmodes/cwarn.el index dfb987bf99a..6e84f4f1bcc 100644 --- a/lisp/progmodes/cwarn.el +++ b/lisp/progmodes/cwarn.el @@ -4,7 +4,7 @@ ;; Author: Anders Lindgren ;; Keywords: c, languages, faces -;; Version: 1.3.1 +;; Old-Version: 1.3.1 ;; This file is part of GNU Emacs. @@ -168,6 +168,8 @@ deactivated." :tag "Load Hook" :group 'cwarn :type 'hook) +(make-obsolete-variable 'cwarn-load-hook + "use `with-eval-after-load' instead." "28.1") ;;}}} ;;{{{ The modes diff --git a/lisp/progmodes/ebnf-abn.el b/lisp/progmodes/ebnf-abn.el index dc6bd44e482..bf9b0e961ba 100644 --- a/lisp/progmodes/ebnf-abn.el +++ b/lisp/progmodes/ebnf-abn.el @@ -474,11 +474,10 @@ (aset ebnf-abn-token-table ?\; 'comment))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-abn-non-terminal-chars - (ebnf-range-regexp "-_0-9A-Za-z" ?\240 ?\377)) + "-_0-9A-Za-z\u00a0-\u00ff") (defconst ebnf-abn-non-terminal-letter-chars - (ebnf-range-regexp "A-Za-z" ?\240 ?\377)) + "A-Za-z\u00a0-\u00ff") (defun ebnf-abn-lex () @@ -572,9 +571,8 @@ See documentation for variable `ebnf-abn-lex'." (not eor-p))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-abn-comment-chars - (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237)) + "^\n\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-abn-skip-comment () @@ -612,9 +610,8 @@ See documentation for variable `ebnf-abn-lex'." (ebnf-buffer-substring ebnf-abn-comment-chars)) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-abn-string-chars - (ebnf-range-regexp " -!#-~" ?\240 ?\377)) + " !#-~\u00a0-\u00ff") (defun ebnf-abn-string () diff --git a/lisp/progmodes/ebnf-bnf.el b/lisp/progmodes/ebnf-bnf.el index 583740d3617..4e11862c1dc 100644 --- a/lisp/progmodes/ebnf-bnf.el +++ b/lisp/progmodes/ebnf-bnf.el @@ -419,9 +419,8 @@ (aset ebnf-bnf-token-table ebnf-lex-eop-char 'period))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-bnf-non-terminal-chars - (ebnf-range-regexp "!#%&'*-,0-:<>@-Z\\\\^-z~" ?\240 ?\377)) + "!#%&'*-,0-:<>@-Z\\\\^-z~\u00a0-\u00ff") (defun ebnf-bnf-lex () @@ -520,9 +519,8 @@ See documentation for variable `ebnf-bnf-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-bnf-comment-chars - (ebnf-range-regexp "^\n\000-\010\016-\037" ?\177 ?\237)) + "^\n\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-bnf-skip-comment () diff --git a/lisp/progmodes/ebnf-dtd.el b/lisp/progmodes/ebnf-dtd.el index 7e824e487aa..bdebf0db2c1 100644 --- a/lisp/progmodes/ebnf-dtd.el +++ b/lisp/progmodes/ebnf-dtd.el @@ -1108,9 +1108,8 @@ (aset ebnf-dtd-token-table ?\] 'end-subset))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-dtd-name-chars - (ebnf-range-regexp "-._:0-9A-Za-z" ?\240 ?\377)) + "-._:0-9A-Za-z\u00a0-\u00ff") (defconst ebnf-dtd-decl-alist @@ -1263,11 +1262,10 @@ See documentation for variable `ebnf-dtd-lex'." (format "%s%s;" start char))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-dtd-double-string-chars - (ebnf-range-regexp "\t -!#-~" ?\240 ?\377)) + "\t -!#-~\u00a0-\u00ff") (defconst ebnf-dtd-single-string-chars - (ebnf-range-regexp "\t -&(-~" ?\240 ?\377)) + "\t -&(-~\u00a0-\u00ff") (defun ebnf-dtd-string (delim) @@ -1287,11 +1285,10 @@ See documentation for variable `ebnf-dtd-lex'." (forward-char))))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-dtd-comment-chars - (ebnf-range-regexp "^-\000-\010\013\014\016-\037" ?\177 ?\237)) + "^-\000-\010\013\014\016-\037\177\u0080-\u009f") (defconst ebnf-dtd-filename-chars - (ebnf-range-regexp "^-\000-\037" ?\177 ?\237)) + "^-\000-\037\177\u0080-\u009f") (defun ebnf-dtd-skip-comment () diff --git a/lisp/progmodes/ebnf-ebx.el b/lisp/progmodes/ebnf-ebx.el index 2ae6fb67569..20e2d4ca31c 100644 --- a/lisp/progmodes/ebnf-ebx.el +++ b/lisp/progmodes/ebnf-ebx.el @@ -405,11 +405,10 @@ (aset ebnf-ebx-token-table ?/ 'comment))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-ebx-non-terminal-chars - (ebnf-range-regexp "-_A-Za-z" ?\240 ?\377)) + "-_A-Za-z\u00a0-\u00ff") (defconst ebnf-ebx-non-terminal-letter-chars - (ebnf-range-regexp "A-Za-z" ?\240 ?\377)) + "A-Za-z\u00a0-\u00ff") (defun ebnf-ebx-lex () @@ -488,9 +487,8 @@ See documentation for variable `ebnf-ebx-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-ebx-constraint-chars - (ebnf-range-regexp "^\000-\010\016-\037]" ?\177 ?\237)) + "^\000-\010\016-\037]\177\u0080-\u009f") (defun ebnf-ebx-skip-constraint () @@ -517,11 +515,10 @@ See documentation for variable `ebnf-ebx-lex'." (not eor-p))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-ebx-comment-chars - (ebnf-range-regexp "^\000-\010\016-\037\\*" ?\177 ?\237)) + "^\000-\010\016-\037*\177\u0080-\u009f") (defconst ebnf-ebx-filename-chars - (ebnf-range-regexp "^\000-\037\\*" ?\177 ?\237)) + "^\000-\037*\177\u0080-\u009f") (defun ebnf-ebx-skip-comment () @@ -581,11 +578,10 @@ See documentation for variable `ebnf-ebx-lex'." (concat fname (make-string nchar ?*))))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-ebx-double-string-chars - (ebnf-range-regexp "\t -!#-~" ?\240 ?\377)) + "\t -!#-~\u00a0-\u00ff") (defconst ebnf-ebx-single-string-chars - (ebnf-range-regexp "\t -&(-~" ?\240 ?\377)) + "\t -&(-~\u00a0-\u00ff") (defun ebnf-ebx-string (delim) diff --git a/lisp/progmodes/ebnf-iso.el b/lisp/progmodes/ebnf-iso.el index b52094a5912..466e7785053 100644 --- a/lisp/progmodes/ebnf-iso.el +++ b/lisp/progmodes/ebnf-iso.el @@ -379,9 +379,8 @@ (aset ebnf-iso-token-table ?. 'character))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). (defconst ebnf-iso-non-terminal-chars - (ebnf-range-regexp " 0-9A-Za-z_" ?\240 ?\377)) + " 0-9A-Za-z_\u00a0-\u00ff") (defun ebnf-iso-lex () @@ -487,9 +486,8 @@ See documentation for variable `ebnf-iso-lex'." )))) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-iso-comment-chars - (ebnf-range-regexp "^*(\000-\010\016-\037" ?\177 ?\237)) + "^*(\000-\010\016-\037\177\u0080-\u009f") (defun ebnf-iso-skip-comment () diff --git a/lisp/progmodes/ebnf-yac.el b/lisp/progmodes/ebnf-yac.el index f5d633e8460..a657c637f82 100644 --- a/lisp/progmodes/ebnf-yac.el +++ b/lisp/progmodes/ebnf-yac.el @@ -397,9 +397,8 @@ See documentation for variable `ebnf-yac-lex'." (< (point) ebnf-limit)) -;; replace the range "\177-\377" (see `ebnf-range-regexp'). (defconst ebnf-yac-skip-chars - (ebnf-range-regexp "^{}/'\"\000-\010\013\016-\037" ?\177 ?\377)) + "^{}/'\"\000-\010\013\016-\037\177\u0080-\u009f") (defun ebnf-yac-skip-code () @@ -442,9 +441,8 @@ See documentation for variable `ebnf-yac-lex'." )) -;; replace the range "\177-\237" (see `ebnf-range-regexp'). (defconst ebnf-yac-comment-chars - (ebnf-range-regexp "^*\000-\010\013\016-\037" ?\177 ?\237)) + "^*\000-\010\013\016-\037\177\u0080-\u009f") (defun ebnf-yac-skip-comment () diff --git a/lisp/progmodes/ebnf2ps.el b/lisp/progmodes/ebnf2ps.el index 640cb576ef6..08cf802bcbe 100644 --- a/lisp/progmodes/ebnf2ps.el +++ b/lisp/progmodes/ebnf2ps.el @@ -1157,21 +1157,6 @@ Please send all bug fixes and enhancements to (and (string< ps-print-version "5.2.3") (error "`ebnf2ps' requires `ps-print' package version 5.2.3 or later")) - -;; to avoid gripes with Emacs 20 -(or (fboundp 'assq-delete-all) - (defun assq-delete-all (key alist) - "Delete from ALIST all elements whose car is KEY. -Return the modified alist. -Elements of ALIST that are not conses are ignored." - (let ((tail alist)) - (while tail - (if (and (consp (car tail)) - (eq (car (car tail)) key)) - (setq alist (delq (car tail) alist))) - (setq tail (cdr tail))) - alist))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; User Variables: @@ -2053,8 +2038,7 @@ It must be a float between 0.0 (top) and 1.0 (bottom)." ;; Printing color requires x-color-values. -(defcustom ebnf-color-p (or (fboundp 'x-color-values) ; Emacs - (fboundp 'color-instance-rgb-components)) ; XEmacs +(defcustom ebnf-color-p t "Non-nil means use color." :type 'boolean :version "20" @@ -2738,8 +2722,7 @@ Used in functions `ebnf-reset-style', `ebnf-push-style' and (ebnf-eps-footer-font . '(7 Helvetica "Black" "White" bold)) (ebnf-eps-footer . nil) (ebnf-entry-percentage . 0.5) - (ebnf-color-p . (or (fboundp 'x-color-values) ; Emacs - (fboundp 'color-instance-rgb-components))) ; XEmacs + (ebnf-color-p . t) (ebnf-line-width . 1.0) (ebnf-line-color . "Black") (ebnf-debug-ps . nil) @@ -4979,18 +4962,6 @@ killed after process termination." (kill-buffer (current-buffer)))) -;; function `ebnf-range-regexp' is used to avoid a bug of `skip-chars-forward' -;; on version 20.4.1, that is, it doesn't accept ranges like "\240-\377" (or -;; "\177-\237"), but it accepts the character sequence from \240 to \377 (or -;; from \177 to \237). It seems that version 20.7 has the same problem. -(defun ebnf-range-regexp (prefix from to) - (let (str) - (while (<= from to) - (setq str (concat str (char-to-string from)) - from (1+ from))) - (concat prefix str))) - - (defvar ebnf-map-name (let ((map (make-vector 256 ?\_))) (mapc #'(lambda (char) @@ -5004,8 +4975,6 @@ killed after process termination." (defun ebnf-eps-filename (str) (let* ((len (length str)) (stri 0) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (new (make-string len ?\ ))) (while (< stri len) (aset new stri (aref ebnf-map-name (aref str stri))) @@ -5987,8 +5956,7 @@ killed after process termination." (point)))) -;; replace the range "\240-\377" (see `ebnf-range-regexp'). -(defconst ebnf-8-bit-chars (ebnf-range-regexp "" ?\240 ?\377)) +(defconst ebnf-8-bit-chars "\u00a0-\u00ff") (defun ebnf-string (chars eos-char kind) @@ -6023,8 +5991,6 @@ killed after process termination." (defun ebnf-trim-right (str) (let* ((len (1- (length str))) (index len)) - ;; to keep compatibility with Emacs 20 & 21: - ;; DO NOT REPLACE `?\ ' BY `?\s' (while (and (> index 0) (= (aref str index) ?\ )) (setq index (1- index))) (if (= index len) diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index bb780259333..1c9e805f039 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -34,6 +34,7 @@ ;;; Code: (require 'cl-lib) +(require 'seq) (require 'easymenu) (require 'view) (require 'ebuff-menu) @@ -52,32 +53,27 @@ "List of directories to search for source files in a class tree. Elements should be directory names; nil as an element means to try to find source files relative to the location of the BROWSE file loaded." - :group 'ebrowse :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) (defcustom ebrowse-view/find-hook nil "Hooks run after finding or viewing a member or class." - :group 'ebrowse :type 'hook) (defcustom ebrowse-not-found-hook nil "Hooks run when finding or viewing a member or class was not successful." - :group 'ebrowse :type 'hook) (defcustom ebrowse-electric-list-mode-hook nil "Hook called by `ebrowse-electric-position-mode'." - :group 'ebrowse :type 'hook) (defcustom ebrowse-max-positions 50 "Number of markers saved on electric position stack." - :group 'ebrowse :type 'integer) @@ -89,32 +85,27 @@ to find source files relative to the location of the BROWSE file loaded." (defcustom ebrowse-tree-mode-hook nil "Hook run in each new tree buffer." - :group 'ebrowse-tree :type 'hook) (defcustom ebrowse-tree-buffer-name "*Tree*" "The default name of class tree buffers." - :group 'ebrowse-tree :type 'string) (defcustom ebrowse--indentation 4 "The amount by which subclasses are indented in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-source-file-column 40 "The column in which source file names are displayed in the tree." - :group 'ebrowse-tree :type 'integer) (defcustom ebrowse-tree-left-margin 2 "Amount of space left at the left side of the tree display. This space is used to display markers." - :group 'ebrowse-tree :type 'integer) @@ -126,25 +117,21 @@ This space is used to display markers." (defcustom ebrowse-default-declaration-column 25 "The column in which member declarations are displayed in member buffers." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-default-column-width 25 "The width of the columns in member buffers (short display form)." - :group 'ebrowse-member :type 'integer) (defcustom ebrowse-member-buffer-name "*Members*" "The name of the buffer for member display." - :group 'ebrowse-member :type 'string) (defcustom ebrowse-member-mode-hook nil "Run in each new member buffer." - :group 'ebrowse-member :type 'hook) @@ -156,81 +143,47 @@ This space is used to display markers." (defface ebrowse-tree-mark '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for the mark character in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for the mark character in the Ebrowse tree.") (defface ebrowse-root-class '((((min-colors 88)) :weight bold :foreground "blue1") (t :weight bold :foreground "blue")) - "Face for root classes in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for root classes in the Ebrowse tree.") (defface ebrowse-file-name '((t :slant italic)) - "Face for filenames in the Ebrowse tree." - :group 'ebrowse-faces) + "Face for filenames in the Ebrowse tree.") (defface ebrowse-default '((t)) - "Face for items in the Ebrowse tree which do not have other faces." - :group 'ebrowse-faces) + "Face for items in the Ebrowse tree which do not have other faces.") (defface ebrowse-member-attribute '((((min-colors 88)) :foreground "red1") (t :foreground "red")) - "Face for member attributes." - :group 'ebrowse-faces) + "Face for member attributes.") (defface ebrowse-member-class '((t :foreground "purple")) - "Face used to display the class title in member buffers." - :group 'ebrowse-faces) + "Face used to display the class title in member buffers.") (defface ebrowse-progress '((((min-colors 88)) :background "blue1") (t :background "blue")) - "Face for progress indicator." - :group 'ebrowse-faces) + "Face for progress indicator.") ;;; Utilities. -(defun ebrowse-some (predicate vector) - "Return true if PREDICATE is true of some element of VECTOR. -If so, return the value returned by PREDICATE." - (let ((length (length vector)) - (i 0) - result) - (while (and (< i length) (not result)) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-some #'seq-some "28.1") -(defun ebrowse-every (predicate vector) - "Return true if PREDICATE is true of every element of VECTOR." - (let ((length (length vector)) - (i 0) - (result t)) - (while (and (< i length) result) - (setq result (funcall predicate (aref vector i)) - i (1+ i))) - result)) +(define-obsolete-function-alias 'ebrowse-every #'seq-every-p "28.1") (defun ebrowse-position (item list &optional test) "Return the position of ITEM in LIST or nil if not found. Compare items with `eq' or TEST if specified." - (let ((i 0) found) - (cond (test - (while list - (when (funcall test item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i)))) - (t - (while list - (when (eq item (car list)) - (setq found i list nil)) - (setq list (cdr list) i (1+ i))))) - found)) + (declare (obsolete seq-position "28.1")) + (seq-position list item (or test #'eql))) (defmacro ebrowse-ignoring-completion-case (&rest body) @@ -242,17 +195,13 @@ Compare items with `eq' or TEST if specified." (defmacro ebrowse-for-all-trees (spec &rest body) "For all trees in SPEC, eval BODY." (declare (indent 1) (debug ((sexp form) body))) - (let ((var (make-symbol "var")) - (spec-var (car spec)) + (let ((spec-var (car spec)) (array (cadr spec))) - `(cl-loop for ,var being the symbols of ,array - as ,spec-var = (get ,var 'ebrowse-root) do - (when (vectorp ,spec-var) - ,@body)))) - -;;; Set indentation for macros above. - - + `(maphash (lambda (_k ,spec-var) + (when ,spec-var + (cl-assert (cl-typep ,spec-var 'ebrowse-ts)) + ,@body)) + ,array))) (defsubst ebrowse-set-face (start end face) "Set face of a region START END to FACE." @@ -264,8 +213,7 @@ Compare items with `eq' or TEST if specified." Case is ignored in completions. PROMPT is a string to prompt with; normally it ends in a colon and a space. -TABLE is an alist whose elements' cars are strings, or an obarray. -TABLE can also be a function to do the completion itself. +TABLE is a completion table. If INITIAL-INPUT is non-nil, insert it in the minibuffer initially. If it is (STRING . POSITION), the initial input is STRING, but point is placed POSITION characters into the string." @@ -304,6 +252,9 @@ otherwise use the current frame's width." ;;; Structure definitions +;; Note: These use `(:type vector) :named' in order to match the +;; format used in src/BROWSE. + (cl-defstruct (ebrowse-hs (:type vector) :named) "Header structure found at the head of BROWSE files." ;; A version string that is compared against the version number of @@ -457,19 +408,17 @@ members." This must be the same that `ebrowse' uses.") -(defvar ebrowse--last-regexp nil +(defvar-local ebrowse--last-regexp nil "Last regular expression searched for in tree and member buffers. Each tree and member buffer maintains its own search history.") -(make-variable-buffer-local 'ebrowse--last-regexp) - (defconst ebrowse-member-list-accessors - '(ebrowse-ts-member-variables - ebrowse-ts-member-functions - ebrowse-ts-static-variables - ebrowse-ts-static-functions - ebrowse-ts-friends - ebrowse-ts-types) + (list #'ebrowse-ts-member-variables + #'ebrowse-ts-member-functions + #'ebrowse-ts-static-variables + #'ebrowse-ts-static-functions + #'ebrowse-ts-friends + #'ebrowse-ts-types) "List of accessors for member lists. Each element is the symbol of an accessor function. The nth element must be the accessor for the nth member list @@ -478,8 +427,8 @@ in an `ebrowse-ts' structure.") ;;; FIXME: Add more doc strings for the buffer-local variables below. -(defvar ebrowse--tree-obarray nil - "Obarray holding all `ebrowse-ts' structures of a class tree. +(defvar ebrowse--tree-table nil + "Hash-table holding all `ebrowse-ts' structures of a class tree. Buffer-local in Ebrowse buffers.") @@ -637,12 +586,12 @@ Buffer-local in Ebrowse buffers.") ;;; Operations on `ebrowse-ts' structures (defun ebrowse-files-table (&optional marked-only) - "Return an obarray containing all files mentioned in the current tree. -The tree is expected in the buffer-local variable `ebrowse--tree-obarray'. + "Return a hash table containing all files mentioned in the current tree. +The tree is expected in the buffer-local variable `ebrowse--tree-table'. MARKED-ONLY non-nil means include marked classes only." (let ((files (make-hash-table :test 'equal)) (i -1)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (or (not marked-only) (ebrowse-ts-mark tree)) (let ((class (ebrowse-ts-class tree))) (when (zerop (% (cl-incf i) 20)) @@ -677,7 +626,7 @@ MARKED-ONLY non-nil means include marked classes only." (cl-defun ebrowse-marked-classes-p () "Value is non-nil if any class in the current class tree is marked." - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (when (ebrowse-ts-mark tree) (cl-return-from ebrowse-marked-classes-p tree)))) @@ -695,21 +644,21 @@ MARKED-ONLY non-nil means include marked classes only." (ebrowse-cs-name class))) -(defun ebrowse-tree-obarray-as-alist (&optional qualified-names-p) +(defun ebrowse-tree-table-as-alist (&optional qualified-names-p) "Return an alist describing all classes in a tree. Each elements in the list has the form (CLASS-NAME . TREE). CLASS-NAME is the name of the class. TREE is the class tree whose root is QUALIFIED-CLASS-NAME. QUALIFIED-NAMES-P non-nil means return qualified names as CLASS-NAME. -The class tree is found in the buffer-local variable `ebrowse--tree-obarray'." +The class tree is found in the buffer-local variable `ebrowse--tree-table'." (let (alist) (if qualified-names-p - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-qualified-class-name (ebrowse-ts-class tree)) tree alist))) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setq alist (cl-acons (ebrowse-cs-name (ebrowse-ts-class tree)) tree alist)))) @@ -751,7 +700,7 @@ computes this information lazily." with result = nil as search = (pop to-search) while search finally return result - do (ebrowse-for-all-trees (ti ebrowse--tree-obarray) + do (ebrowse-for-all-trees (ti ebrowse--tree-table) (when (memq search (ebrowse-ts-subclasses ti)) (unless (memq ti result) (setq result (nconc result (list ti)))) @@ -875,7 +824,7 @@ NOCONFIRM." "Create a new tree buffer for tree TREE. The tree was loaded from file TAGS-FILE. HEADER is the header structure of the file. -CLASSES is an obarray with a symbol for each class in the tree. +CLASSES is a hash-table with an entry for each class in the tree. POP non-nil means popup the buffer up at the end. Return the buffer created." (let ((name ebrowse-tree-buffer-name)) @@ -883,7 +832,7 @@ Return the buffer created." (ebrowse-tree-mode) (setq ebrowse--tree tree ebrowse--tags-file-name tags-file - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--header header ebrowse--frozen-flag nil) (ebrowse-redraw-tree) @@ -895,13 +844,13 @@ Return the buffer created." -;;; Operations for member obarrays +;;; Operations for member tables (defun ebrowse-fill-member-table () - "Return an obarray holding all members of all classes in the current tree. + "Return a hash table holding all members of all classes in the current tree. -For each member, a symbol is added to the obarray. Members are -extracted from the buffer-local tree `ebrowse--tree-obarray'. +For each member, a symbol is added to the table. Members are +extracted from the buffer-local tree `ebrowse--tree-table'. Each symbol has its property `ebrowse-info' set to a list (TREE MEMBER-LIST MEMBER) where TREE is the tree in which the member is defined, @@ -909,26 +858,23 @@ MEMBER-LIST is a symbol describing the member list in which the member is found, and MEMBER is a MEMBER structure describing the member. The slot `member-table' of the buffer-local header structure of -type `ebrowse-hs' is set to the resulting obarray." +type `ebrowse-hs' is set to the resulting table." (let ((members (make-hash-table :test 'equal)) (i -1)) (setf (ebrowse-hs-member-table ebrowse--header) nil) (garbage-collect) ;; For all classes... - (ebrowse-for-all-trees (c ebrowse--tree-obarray) + (ebrowse-for-all-trees (c ebrowse--tree-table) (when (zerop (% (cl-incf i) 10)) (ebrowse-show-progress "Preparing member lookup" (zerop i))) (dolist (f ebrowse-member-list-accessors) (dolist (m (funcall f c)) - (let* ((member-name (ebrowse-ms-name m)) - (value (gethash member-name members))) - (push (list c f m) value) - (puthash member-name value members))))) + (push (list c f m) (gethash (ebrowse-ms-name m) members))))) (setf (ebrowse-hs-member-table ebrowse--header) members))) (defun ebrowse-member-table (header) - "Return the member obarray. Build it if it hasn't been set up yet. + "Return the member table. Build it if it hasn't been set up yet. HEADER is the tree header structure of the class tree." (when (null (ebrowse-hs-member-table header)) (cl-loop for buffer in (ebrowse-browser-buffer-list) @@ -940,19 +886,18 @@ HEADER is the tree header structure of the class tree." -;;; Operations on TREE obarrays +;;; Operations on TREE tables -(defun ebrowse-build-tree-obarray (tree) +(defun ebrowse-build-tree-table (tree) "Make sure every class in TREE is represented by a unique object. -Build obarray of all classes in TREE." - (let ((classes (make-vector 127 0))) +Build hash table of all classes in TREE." + (let ((classes (make-hash-table :test #'equal))) ;; Add root classes... (cl-loop for root in tree - as sym = - (intern (ebrowse-qualified-class-name (ebrowse-ts-class root)) - classes) - do (unless (get sym 'ebrowse-root) - (setf (get sym 'ebrowse-root) root))) + do (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class root)))) + (unless (gethash name classes) + (setf (gethash name classes) root)))) ;; Process subclasses (ebrowse-insert-supers tree classes) classes)) @@ -962,7 +907,7 @@ Build obarray of all classes in TREE." "Build base class lists in class tree TREE. CLASSES is an obarray used to collect classes. -Helper function for `ebrowse-build-tree-obarray'. Base classes should +Helper function for `ebrowse-build-tree-table'. Base classes should be ordered so that immediate base classes come first, then the base class of the immediate base class and so on. This means that we must construct the base-class list top down with adding each level at the @@ -974,23 +919,21 @@ if for some reason a circle is in the inheritance graph." as subclasses = (ebrowse-ts-subclasses class) do ;; Make sure every class is represented by a unique object (cl-loop for subclass on subclasses - as sym = (intern - (ebrowse-qualified-class-name - (ebrowse-ts-class (car subclass))) - classes) do - ;; Replace the subclass tree with the one found in - ;; CLASSES if there is already an entry for that class - ;; in it. Otherwise make a new entry. - ;; - ;; CAVEAT: If by some means (e.g., use of the - ;; preprocessor in class declarations, a name is marked - ;; as a subclass of itself on some path, we would end up - ;; in an endless loop. We have to omit subclasses from - ;; the recursion that already have been processed. - (if (get sym 'ebrowse-root) - (setf (car subclass) (get sym 'ebrowse-root)) - (setf (get sym 'ebrowse-root) (car subclass)))) + (let ((name (ebrowse-qualified-class-name + (ebrowse-ts-class (car subclass))))) + ;; Replace the subclass tree with the one found in + ;; CLASSES if there is already an entry for that class + ;; in it. Otherwise make a new entry. + ;; + ;; CAVEAT: If by some means (e.g., use of the + ;; preprocessor in class declarations, a name is marked + ;; as a subclass of itself on some path, we would end up + ;; in an endless loop. We have to omit subclasses from + ;; the recursion that already have been processed. + (if (gethash name classes) + (setf (car subclass) (gethash name classes)) + (setf (gethash name classes) (car subclass))))) ;; Process subclasses (ebrowse-insert-supers subclasses classes))) @@ -1072,20 +1015,17 @@ Tree mode key bindings: (erase-buffer) (message nil)) - (set (make-local-variable 'ebrowse--show-file-names-flag) nil) - (set (make-local-variable 'ebrowse--tree-obarray) (make-vector 127 0)) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local ebrowse--show-file-names-flag nil) + (setq-local ebrowse--frozen-flag nil) (setq mode-line-buffer-identification ident) (setq buffer-read-only t) (add-to-invisibility-spec '(ebrowse . t)) - (set (make-local-variable 'revert-buffer-function) - #'ebrowse-revert-tree-buffer-from-file) - (set (make-local-variable 'ebrowse--header) header) - (set (make-local-variable 'ebrowse--tree) tree) - (set (make-local-variable 'ebrowse--tags-file-name) buffer-file-name) - (set (make-local-variable 'ebrowse--tree-obarray) - (and tree (ebrowse-build-tree-obarray tree))) - (set (make-local-variable 'ebrowse--frozen-flag) nil) + (setq-local revert-buffer-function #'ebrowse-revert-tree-buffer-from-file) + (setq-local ebrowse--header header) + (setq-local ebrowse--tree tree) + (setq-local ebrowse--tags-file-name buffer-file-name) + (setq-local ebrowse--tree-table (and tree (ebrowse-build-tree-table tree))) + (setq-local ebrowse--frozen-flag nil) (add-hook 'write-file-functions #'ebrowse-write-file-hook-fn nil t) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a))) @@ -1110,18 +1050,18 @@ Tree mode key bindings: (defun ebrowse-remove-class-and-kill-member-buffers (tree class) "Remove from TREE class CLASS. Kill all member buffers still containing a reference to the class." - (let ((sym (intern-soft (ebrowse-cs-name (ebrowse-ts-class class)) - ebrowse--tree-obarray))) - (setf tree (delq class tree) - (get sym 'ebrowse-root) nil) - (dolist (root tree) - (setf (ebrowse-ts-subclasses root) - (delq class (ebrowse-ts-subclasses root)) - (ebrowse-ts-base-classes root) nil) - (ebrowse-remove-class-and-kill-member-buffers - (ebrowse-ts-subclasses root) class)) - (ebrowse-kill-member-buffers-displaying class) - tree)) + (setf tree (delq class tree) + (gethash (ebrowse-cs-name (ebrowse-ts-class class)) + ebrowse--tree-table) + nil) + (dolist (root tree) + (setf (ebrowse-ts-subclasses root) + (delq class (ebrowse-ts-subclasses root)) + (ebrowse-ts-base-classes root) nil) + (ebrowse-remove-class-and-kill-member-buffers + (ebrowse-ts-subclasses root) class)) + (ebrowse-kill-member-buffers-displaying class) + tree) (defun ebrowse-remove-class-at-point (forced) @@ -1184,7 +1124,7 @@ If given a numeric N-TIMES argument, mark that many classes." (defun ebrowse-mark-all-classes (prefix) "Unmark, with PREFIX mark, all classes in the tree." (interactive "P") - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (setf (ebrowse-ts-mark tree) prefix)) (ebrowse-redraw-marks (point-min) (point-max))) @@ -1277,17 +1217,17 @@ With PREFIX, insert that many filenames." (defun ebrowse-browser-buffer-list () "Return a list of all tree or member buffers." - (cl-delete-if-not 'ebrowse-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-buffer-p (buffer-list))) (defun ebrowse-member-buffer-list () "Return a list of all member buffers." - (cl-delete-if-not 'ebrowse-member-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-member-buffer-p (buffer-list))) (defun ebrowse-tree-buffer-list () "Return a list of all tree buffers." - (cl-delete-if-not 'ebrowse-tree-buffer-p (buffer-list))) + (cl-delete-if-not #'ebrowse-tree-buffer-p (buffer-list))) (defun ebrowse-known-class-trees-buffer-list () @@ -1396,7 +1336,7 @@ Pop to member buffer if no prefix ARG, to tree buffer otherwise." "): ") nil nil ebrowse--indentation)))) (when (cl-plusp width) - (set (make-local-variable 'ebrowse--indentation) width) + (setq-local ebrowse--indentation width) (ebrowse-redraw-tree)))) @@ -1409,7 +1349,7 @@ Read a class name from the minibuffer if CLASS is nil." (unless class (setf class (completing-read "Goto class: " - (ebrowse-tree-obarray-as-alist) nil t))) + (ebrowse-tree-table-as-alist) nil t))) (goto-char (point-min)) (widen) (setq ebrowse--last-regexp (concat "\\b" class "\\b")) @@ -1426,37 +1366,37 @@ Read a class name from the minibuffer if CLASS is nil." (defun ebrowse-tree-command:show-member-variables (arg) "Display member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-variables arg)) (defun ebrowse-tree-command:show-member-functions (&optional arg) "Display member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-member-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-member-functions arg)) (defun ebrowse-tree-command:show-static-member-variables (arg) "Display static member variables; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-variables arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-variables arg)) (defun ebrowse-tree-command:show-static-member-functions (arg) "Display static member functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-static-functions arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-static-functions arg)) (defun ebrowse-tree-command:show-friends (arg) "Display friend functions; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-friends arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-friends arg)) (defun ebrowse-tree-command:show-types (arg) "Display types defined in a class; with prefix ARG in frozen member buffer." (interactive "P") - (ebrowse-display-member-buffer 'ebrowse-ts-types arg)) + (ebrowse-display-member-buffer #'ebrowse-ts-types arg)) @@ -1562,12 +1502,12 @@ The new frame is deleted when you quit viewing the file in that frame." (had-a-buf (get-file-buffer file)) (buf-to-view (find-file-noselect file))) (switch-to-buffer-other-frame buf-to-view) - (set (make-local-variable 'ebrowse--frame-configuration) + (setq-local ebrowse--frame-configuration old-frame-configuration) - (set (make-local-variable 'ebrowse--view-exit-action) + (setq-local ebrowse--view-exit-action (and (not had-a-buf) (not (buffer-modified-p buf-to-view)) - 'kill-buffer)) + #'kill-buffer)) (view-mode-enter (cons (selected-window) (cons (selected-window) t)) 'ebrowse-view-exit-fn))) @@ -1934,7 +1874,7 @@ COLLAPSE non-nil means collapse the branch." (when (memq 'mode-name mode-line-format) (setq mode-line-format (copy-sequence mode-line-format)) (setcar (memq 'mode-name mode-line-format) "Tree Buffers")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -2145,41 +2085,31 @@ See `Electric-command-loop' for a description of STATE and CONDITION." (define-derived-mode ebrowse-member-mode special-mode "Ebrowse-Members" "Major mode for Ebrowse member buffers." (mapc #'make-local-variable - '(ebrowse--decl-column ;display column - ebrowse--n-columns ;number of short columns - ebrowse--column-width ;width of columns above - ebrowse--show-inherited-flag ;include inherited members? - ebrowse--filters ;public, protected, private + '(ebrowse--n-columns ;number of short columns ebrowse--accessor ;vars, functions, friends ebrowse--displayed-class ;class displayed - ebrowse--long-display-flag ;display with regexps? - ebrowse--source-regexp-flag ;show source regexp? - ebrowse--attributes-flag ;show `virtual' and `inline' ebrowse--member-list ;list of members displayed ebrowse--tree ;the class tree ebrowse--member-mode-strings ;part of mode line ebrowse--tags-file-name ; ebrowse--header - ebrowse--tree-obarray - ebrowse--virtual-display-flag - ebrowse--inline-display-flag - ebrowse--const-display-flag - ebrowse--pure-display-flag + ebrowse--tree-table ebrowse--frozen-flag)) ;buffer not automagically reused - (setq mode-line-buffer-identification - (propertized-buffer-identification "C++ Members") - buffer-read-only t - ebrowse--long-display-flag nil - ebrowse--attributes-flag t - ebrowse--show-inherited-flag t - ebrowse--source-regexp-flag nil - ebrowse--filters [0 1 2] - ebrowse--decl-column ebrowse-default-declaration-column - ebrowse--column-width ebrowse-default-column-width - ebrowse--virtual-display-flag nil - ebrowse--inline-display-flag nil - ebrowse--const-display-flag nil - ebrowse--pure-display-flag nil) + (setq-local + mode-line-buffer-identification + (propertized-buffer-identification "C++ Members") + buffer-read-only t + ebrowse--long-display-flag nil ;display with regexps? + ebrowse--attributes-flag t ;show `virtual' and `inline' + ebrowse--show-inherited-flag t ;include inherited members? + ebrowse--source-regexp-flag nil ;show source regexp? + ebrowse--filters [0 1 2] ;public, protected, private + ebrowse--decl-column ebrowse-default-declaration-column ;display column + ebrowse--column-width ebrowse-default-column-width ;width of columns above + ebrowse--virtual-display-flag nil + ebrowse--inline-display-flag nil + ebrowse--const-display-flag nil + ebrowse--pure-display-flag nil) (modify-syntax-entry ?_ (char-to-string (char-syntax ?a)))) @@ -2257,10 +2187,10 @@ make one." (ebrowse-create-tree-buffer ebrowse--tree ebrowse--tags-file-name ebrowse--header - ebrowse--tree-obarray + ebrowse--tree-table 'pop)))) (and buf - (funcall (if arg 'switch-to-buffer 'pop-to-buffer) buf)) + (funcall (if arg #'switch-to-buffer #'pop-to-buffer) buf)) buf)) @@ -2276,8 +2206,9 @@ make one." (defun ebrowse-cyclic-display-next/previous-member-list (incr) "Switch buffer to INCR'th next/previous list of members." - (let ((index (ebrowse-position ebrowse--accessor - ebrowse-member-list-accessors))) + (let ((index (seq-position ebrowse-member-list-accessors + ebrowse--accessor + #'eql))) (setf ebrowse--accessor (cond ((cl-plusp incr) (or (nth (1+ index) @@ -2306,37 +2237,37 @@ make one." (defun ebrowse-display-function-member-list () "Display the list of member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-functions)) (defun ebrowse-display-variables-member-list () "Display the list of member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-member-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-member-variables)) (defun ebrowse-display-static-variables-member-list () "Display the list of static member variables." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-variables)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-variables)) (defun ebrowse-display-static-functions-member-list () "Display the list of static member functions." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-static-functions)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-static-functions)) (defun ebrowse-display-friends-member-list () "Display the list of friends." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-friends)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-friends)) (defun ebrowse-display-types-member-list () "Display the list of types." (interactive) - (ebrowse-display-member-list-for-accessor 'ebrowse-ts-types)) + (ebrowse-display-member-list-for-accessor #'ebrowse-ts-types)) @@ -2565,8 +2496,8 @@ TAGS-FILE is the file name of the BROWSE file." "Force buffer redisplay." (interactive) (let ((display-fn (if ebrowse--long-display-flag - 'ebrowse-draw-member-long-fn - 'ebrowse-draw-member-short-fn))) + #'ebrowse-draw-member-long-fn + #'ebrowse-draw-member-short-fn))) (with-silent-modifications (erase-buffer) ;; Show this class @@ -2610,7 +2541,7 @@ the class cursor is on." "Start point for member buffer creation. LIST is the member list to display. STAND-ALONE non-nil means the member buffer is standalone. CLASS is its class." - (let* ((classes ebrowse--tree-obarray) + (let* ((classes ebrowse--tree-table) (tree ebrowse--tree) (tags-file ebrowse--tags-file-name) (header ebrowse--header) @@ -2630,7 +2561,7 @@ means the member buffer is standalone. CLASS is its class." (setq ebrowse--member-list (funcall list class) ebrowse--displayed-class class ebrowse--accessor list - ebrowse--tree-obarray classes + ebrowse--tree-table classes ebrowse--frozen-flag stand-alone ebrowse--tags-file-name tags-file ebrowse--header header @@ -2842,7 +2773,7 @@ REPEAT, if specified, says repeat the search REPEAT times." (cl-defun ebrowse-move-point-to-member (name &optional count &aux member) - "Set point on member NAME in the member buffer + "Set point on member NAME in the member buffer. COUNT, if specified, says search the COUNT'th member with the same name." (goto-char (point-min)) (widen) @@ -2867,7 +2798,8 @@ COMPL-LIST is a completion list to use." (class (or (ebrowse-completing-read-value title compl-list initial) (error "Not found")))) (setf ebrowse--displayed-class class - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) @@ -2875,7 +2807,9 @@ COMPL-LIST is a completion list to use." "Switch member buffer to a class read from the minibuffer." (interactive) (ebrowse-switch-member-buffer-to-other-class - "Goto class: " (ebrowse-tree-obarray-as-alist))) + "Goto class: " + ;; FIXME: Why not use the hash-table as-is? + (ebrowse-tree-table-as-alist))) (defun ebrowse-switch-member-buffer-to-base-class (arg) @@ -2927,8 +2861,9 @@ Prefix arg INC specifies which one." (cl-first supers)))) (unless tree (error "Not found")) (setq containing-list (ebrowse-ts-subclasses tree))))) - (setq index (+ inc (ebrowse-position ebrowse--displayed-class - containing-list))) + (setq index (+ inc (seq-position containing-list + ebrowse--displayed-class + #'eql))) (cond ((cl-minusp index) (message "No previous class")) ((null (nth index containing-list)) (message "No next class"))) (setq index (max 0 (min index (1- (length containing-list))))) @@ -2943,16 +2878,16 @@ Prefix arg INC specifies which one." Prefix arg ARG says which class should be displayed. Default is the first derived class." (interactive "P") - (cl-flet ((ebrowse-tree-obarray-as-alist () + (cl-flet ((ebrowse-tree-table-as-alist () (cl-loop for s in (ebrowse-ts-subclasses ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + collect (cons (ebrowse-cs-name (ebrowse-ts-class s)) + s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) (if (and arg (cl-second subs)) (ebrowse-switch-member-buffer-to-other-class - "Goto derived class: " (ebrowse-tree-obarray-as-alist)) + "Goto derived class: " (ebrowse-tree-table-as-alist)) (setq ebrowse--displayed-class (cl-first subs) ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) @@ -3403,7 +3338,8 @@ It is a list (TREE ACCESSOR MEMBER)." (switch-to-buffer buffer) (setq ebrowse--displayed-class (cl-first info) ebrowse--accessor (cl-second info) - ebrowse--member-list (funcall ebrowse--accessor ebrowse--displayed-class)) + ebrowse--member-list (funcall ebrowse--accessor + ebrowse--displayed-class)) (ebrowse-redisplay-member-buffer))) (ebrowse-move-point-to-member (ebrowse-ms-name (cl-third info))))) @@ -3513,28 +3449,20 @@ KIND is an additional string printed in the buffer." (_ "unknown")) "\n"))) -(defvar ebrowse-last-completion nil +(defvar-local ebrowse-last-completion nil "Text inserted by the last completion operation.") -(defvar ebrowse-last-completion-start nil +(defvar-local ebrowse-last-completion-start nil "String which was the basis for the last completion operation.") -(defvar ebrowse-last-completion-location nil +(defvar-local ebrowse-last-completion-location nil "Buffer position at which the last completion operation was initiated.") -(defvar ebrowse-last-completion-obarray nil +(defvar-local ebrowse-last-completion-table nil "Member used in last completion operation.") - - -(make-variable-buffer-local 'ebrowse-last-completion-obarray) -(make-variable-buffer-local 'ebrowse-last-completion-location) -(make-variable-buffer-local 'ebrowse-last-completion) -(make-variable-buffer-local 'ebrowse-last-completion-start) - - (defun ebrowse-some-member-table () "Return a hash table containing all members of a tree. @@ -3552,7 +3480,7 @@ use choose a tree." (defun ebrowse-cyclic-successor-in-string-list (string list) "Return the item following STRING in LIST. If STRING is the last element, return the first element as successor." - (or (nth (1+ (ebrowse-position string list 'string=)) list) + (or (nth (1+ (seq-position list string #'string=)) list) (cl-first list))) @@ -3583,7 +3511,7 @@ completion." ;; expansion ended, insert the next expansion. ((eq (point) ebrowse-last-completion-location) (setf list (all-completions ebrowse-last-completion-start - ebrowse-last-completion-obarray) + ebrowse-last-completion-table) completion (ebrowse-cyclic-successor-in-string-list ebrowse-last-completion list)) (cond ((null completion) @@ -3599,7 +3527,7 @@ completion." ;; buffer: Start new completion. (t (let* ((members (ebrowse-some-member-table)) - (completion (cl-first (all-completions pattern members nil)))) + (completion (cl-first (all-completions pattern members)))) (cond ((eq completion t)) ((null completion) (error "Can't find completion for `%s'" pattern)) @@ -3610,14 +3538,14 @@ completion." (setf ebrowse-last-completion-location (point) ebrowse-last-completion-start pattern ebrowse-last-completion completion - ebrowse-last-completion-obarray members)))))))) + ebrowse-last-completion-table members)))))))) ;;; Tags query replace & search -(defvar ebrowse-tags-loop-form () - "Form for `ebrowse-loop-continue'. -Evaluated for each file in the tree. If it returns nil, proceed +(defvar ebrowse-tags-loop-call '(ignore) + "Function call for `ebrowse-loop-continue'. +Passed to `apply' for each file in the tree. If it returns nil, proceed with the next file.") (defvar ebrowse-tags-next-file-list () @@ -3684,7 +3612,7 @@ TREE-BUFFER if indirectly specifies which files to loop over." (when first-time (ebrowse-tags-next-file first-time tree-buffer) (goto-char (point-min))) - (while (not (eval ebrowse-tags-loop-form)) + (while (not (apply ebrowse-tags-loop-call)) (ebrowse-tags-next-file) (message "Scanning file `%s'..." buffer-file-name) (goto-char (point-min)))) @@ -3697,9 +3625,9 @@ If marked classes exist, process marked classes, only. If regular expression is nil, repeat last search." (interactive "sTree search (regexp): ") (if (and (string= regexp "") - (eq (car ebrowse-tags-loop-form) 're-search-forward)) + (eq (car ebrowse-tags-loop-call) #'re-search-forward)) (ebrowse-tags-loop-continue) - (setq ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + (setq ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time))) @@ -3709,10 +3637,11 @@ If regular expression is nil, repeat last search." With prefix arg, process files of marked classes only." (interactive "sTree query replace (regexp): \nsTree query replace %s by: ") - (setq ebrowse-tags-loop-form - (list 'and (list 'save-excursion - (list 're-search-forward from nil t)) - (list 'not (list 'perform-replace from to t t nil)))) + (setq ebrowse-tags-loop-call + (list (lambda () + (and (save-excursion + (re-search-forward from nil t)) + (not (perform-replace from to t t nil)))))) (ebrowse-tags-loop-continue 'first-time)) @@ -3737,7 +3666,7 @@ looks like a function call to the member." (cl-values-list (ebrowse-tags-read-name header "Find calls of: ")))) ;; Set tags loop form to search for member and begin loop. (setq regexp (concat "\\<" name "[ \t]*(") - ebrowse-tags-loop-form (list 're-search-forward regexp nil t)) + ebrowse-tags-loop-call `(re-search-forward ,regexp nil t)) (ebrowse-tags-loop-continue 'first-time tree-buffer)))) @@ -3746,7 +3675,7 @@ looks like a function call to the member." ;;; Structures of this kind are the elements of the position stack. -(cl-defstruct (ebrowse-position (:type vector) :named) +(cl-defstruct (ebrowse-position) file-name ; in which file point ; point in file target ; t if target of a jump @@ -3839,18 +3768,10 @@ Prefix arg ARG says how much." ;;; Electric position list -(defvar ebrowse-electric-position-mode-map () - "Keymap used in electric position stack window.") - - -(defvar ebrowse-electric-position-mode-hook nil - "If non-nil, its value is called by `ebrowse-electric-position-mode'.") - - -(unless ebrowse-electric-position-mode-map +(defvar ebrowse-electric-position-mode-map (let ((map (make-keymap)) (submap (make-keymap))) - (setq ebrowse-electric-position-mode-map map) + ;; FIXME: Yuck! (fillarray (car (cdr map)) 'ebrowse-electric-position-undefined) (fillarray (car (cdr submap)) 'ebrowse-electric-position-undefined) (define-key map "\e" submap) @@ -3873,14 +3794,19 @@ Prefix arg ARG says how much." (define-key map "\e\C-v" 'scroll-other-window) (define-key map "\e>" 'end-of-buffer) (define-key map "\e<" 'beginning-of-buffer) - (define-key map "\e>" 'end-of-buffer))) + (define-key map "\e>" 'end-of-buffer) + map) + "Keymap used in electric position stack window.") + + +(defvar ebrowse-electric-position-mode-hook nil + "If non-nil, its value is called by `ebrowse-electric-position-mode'.") -(put 'ebrowse-electric-position-mode 'mode-class 'special) (put 'ebrowse-electric-position-undefined 'suppress-keymap t) (define-derived-mode ebrowse-electric-position-mode - fundamental-mode "Electric Position Menu" + special-mode "Electric Position Menu" "Mode for electric position buffers. Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-buffer-identification "Electric Position Menu") @@ -3888,7 +3814,7 @@ Runs the hook `ebrowse-electric-position-mode-hook'." (setq mode-line-format (copy-sequence mode-line-format)) ;; FIXME: Why not set `mode-name' to "Positions"? (setcar (memq 'mode-name mode-line-format) "Positions")) - (set (make-local-variable 'Helper-return-blurb) "return to buffer editing") + (setq-local Helper-return-blurb "return to buffer editing") (setq truncate-lines t buffer-read-only t)) @@ -4101,7 +4027,7 @@ NUMBER-OF-INSTANCE-VARIABLES NUMBER-OF-STATIC-FUNCTIONS NUMBER-OF-STATIC-VARIABLES:" (let ((classes 0) (member-functions 0) (member-variables 0) (static-functions 0) (static-variables 0)) - (ebrowse-for-all-trees (tree ebrowse--tree-obarray) + (ebrowse-for-all-trees (tree ebrowse--tree-table) (cl-incf classes) (cl-incf member-functions (length (ebrowse-ts-member-functions tree))) (cl-incf member-variables (length (ebrowse-ts-member-variables tree))) @@ -4391,10 +4317,4 @@ EVENT is the mouse event." (provide 'ebrowse) - -;; Local variables: -;; eval:(put 'ebrowse-ignoring-completion-case 'lisp-indent-hook 0) -;; eval:(put 'ebrowse-for-all-trees 'lisp-indent-hook 1) -;; End: - ;;; ebrowse.el ends here diff --git a/lisp/progmodes/elisp-mode.el b/lisp/progmodes/elisp-mode.el index f39ecf9b7bc..2f44118edb5 100644 --- a/lisp/progmodes/elisp-mode.el +++ b/lisp/progmodes/elisp-mode.el @@ -231,8 +231,35 @@ Comments in the form will be lost." (setq-local electric-pair-text-pairs elisp-pairs))))) (remove-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) +(defun elisp-enable-lexical-binding (&optional interactive) + "Make the current buffer use `lexical-binding'." + (interactive "p") + (if lexical-binding + (when interactive + (message "lexical-binding already enabled!") + (ding)) + (when (or (not interactive) + (y-or-n-p (format "Enable lexical-binding in this %s? " + (if buffer-file-name "file" "buffer")))) + (setq-local lexical-binding t) + (add-file-local-variable-prop-line 'lexical-binding t interactive)))) + +(defvar elisp--dynlex-modeline-map + (let ((map (make-sparse-keymap))) + (define-key map [mode-line mouse-1] 'elisp-enable-lexical-binding) + map)) + ;;;###autoload -(define-derived-mode emacs-lisp-mode prog-mode "Emacs-Lisp" +(define-derived-mode emacs-lisp-mode lisp-data-mode + `("ELisp" + (lexical-binding (:propertize "/l" + help-echo "Using lexical-binding mode") + (:propertize "/d" + help-echo "Using old dynamic scoping mode\n\ +mouse-1: Enable lexical-binding mode" + face warning + mouse-face mode-line-highlight + local-map ,elisp--dynlex-modeline-map))) "Major mode for editing Lisp code to run in Emacs. Commands: Delete converts tabs to spaces as it moves back. @@ -241,35 +268,28 @@ Blank lines separate paragraphs. Semicolons start comments. \\{emacs-lisp-mode-map}" :group 'lisp (defvar project-vc-external-roots-function) - (lisp-mode-variables nil nil 'elisp) + (setcar font-lock-defaults + '(lisp-el-font-lock-keywords + lisp-el-font-lock-keywords-1 + lisp-el-font-lock-keywords-2)) + (setf (nth 2 font-lock-defaults) nil) (add-hook 'after-load-functions #'elisp--font-lock-flush-elisp-buffers) (if (boundp 'electric-pair-text-pairs) (setq-local electric-pair-text-pairs - (append '((?\` . ?\') (?‘ . ?’)) + (append '((?\` . ?\') (?\‘ . ?\’)) electric-pair-text-pairs)) (add-hook 'electric-pair-mode-hook #'emacs-lisp-set-electric-text-pairs)) - (setq-local electric-quote-string t) - (setq imenu-case-fold-search nil) - (add-function :before-until (local 'eldoc-documentation-function) - #'elisp-eldoc-documentation-function) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-funcall nil t) + (add-hook 'eldoc-documentation-functions + #'elisp-eldoc-var-docstring nil t) (add-hook 'xref-backend-functions #'elisp--xref-backend nil t) (setq-local project-vc-external-roots-function #'elisp-load-path-roots) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil 'local) - ;; .dir-locals.el and lock files will cause the byte-compiler and - ;; checkdoc emit spurious warnings, because they don't follow the - ;; conventions of Emacs Lisp sources. Until we have a better fix, - ;; like teaching elisp-mode about files that only hold data - ;; structures, we disable the ELisp Flymake backend for these files. - (unless - (let* ((bfname (buffer-file-name)) - (fname (and (stringp bfname) (file-name-nondirectory bfname)))) - (and (stringp fname) - (or (string-match "\\`\\.#" fname) - (string-equal dir-locals-file fname)))) - (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) - (add-hook 'flymake-diagnostic-functions - #'elisp-flymake-byte-compile nil t))) + (add-hook 'flymake-diagnostic-functions #'elisp-flymake-checkdoc nil t) + (add-hook 'flymake-diagnostic-functions + #'elisp-flymake-byte-compile nil t)) ;; Font-locking support. @@ -637,18 +657,16 @@ functions are annotated with \"<f>\" via the ;; WORKAROUND: This is nominally a constant, but the text properties ;; are not preserved thru dump if use defconst. See bug#21237. (defvar elisp--xref-format - (let ((str "(%s %s)")) - (put-text-property 1 3 'face 'font-lock-keyword-face str) - (put-text-property 4 6 'face 'font-lock-function-name-face str) - str)) + #("(%s %s)" + 1 3 (face font-lock-keyword-face) + 4 6 (face font-lock-function-name-face))) ;; WORKAROUND: This is nominally a constant, but the text properties ;; are not preserved thru dump if use defconst. See bug#21237. (defvar elisp--xref-format-extra - (let ((str "(%s %s %s)")) - (put-text-property 1 3 'face 'font-lock-keyword-face str) - (put-text-property 4 6 'face 'font-lock-function-name-face str) - str)) + #("(%s %s %s)" + 1 3 (face font-lock-keyword-face) + 4 6 (face font-lock-function-name-face))) (defvar find-feature-regexp);; in find-func.el @@ -845,11 +863,12 @@ non-nil result supercedes the xrefs produced by xrefs)) -(declare-function project-external-roots "project") +(declare-function xref-apropos-regexp "xref" (pattern)) -(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) regexp) +(cl-defmethod xref-backend-apropos ((_backend (eql elisp)) pattern) (apply #'nconc - (let (lst) + (let ((regexp (xref-apropos-regexp pattern)) + lst) (dolist (sym (apropos-internal regexp)) (push (elisp--xref-find-definitions sym) lst)) (nreverse lst)))) @@ -1386,20 +1405,27 @@ which see." or argument string for functions. 2 - `function' if function args, `variable' if variable documentation.") -(defun elisp-eldoc-documentation-function () - "`eldoc-documentation-function' (which see) for Emacs Lisp." - (let ((current-symbol (elisp--current-symbol)) - (current-fnsym (elisp--fnsym-in-current-sexp))) - (cond ((null current-fnsym) - nil) - ((eq current-symbol (car current-fnsym)) - (or (apply #'elisp-get-fnsym-args-string current-fnsym) - (elisp-get-var-docstring current-symbol))) - (t - (or (elisp-get-var-docstring current-symbol) - (apply #'elisp-get-fnsym-args-string current-fnsym)))))) - -(defun elisp-get-fnsym-args-string (sym &optional index prefix) +(defun elisp-eldoc-funcall (callback &rest _ignored) + "Document function call at point. +Intended for `eldoc-documentation-functions' (which see)." + (let* ((sym-info (elisp--fnsym-in-current-sexp)) + (fn-sym (car sym-info))) + (when fn-sym + (funcall callback (apply #'elisp-get-fnsym-args-string sym-info) + :thing fn-sym + :face (if (functionp fn-sym) + 'font-lock-function-name-face + 'font-lock-keyword-face))))) + +(defun elisp-eldoc-var-docstring (callback &rest _ignored) + "Document variable at point. +Intended for `eldoc-documentation-functions' (which see)." + (let ((sym (elisp--current-symbol))) + (when sym (funcall callback (elisp-get-var-docstring sym) + :thing sym + :face 'font-lock-variable-name-face)))) + +(defun elisp-get-fnsym-args-string (sym &optional index) "Return a string containing the parameter list of the function SYM. If SYM is a subr and no arglist is obtainable from the docstring or elsewhere, return a 1-line docstring." @@ -1425,20 +1451,13 @@ or elsewhere, return a 1-line docstring." ;; Stringify, and store before highlighting, downcasing, etc. (elisp--last-data-store sym (elisp-function-argstring args) 'function)))))) - ;; Highlight, truncate. + ;; Highlight (if argstring (elisp--highlight-function-argument - sym argstring index - (or prefix - (concat (propertize (symbol-name sym) 'face - (if (functionp sym) - 'font-lock-function-name-face - 'font-lock-keyword-face)) - ": ")))))) - -(defun elisp--highlight-function-argument (sym args index prefix) - "Highlight argument INDEX in ARGS list for function SYM. -In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." + sym argstring index)))) + +(defun elisp--highlight-function-argument (sym args index) + "Highlight argument INDEX in ARGS list for function SYM." ;; FIXME: This should probably work on the list representation of `args' ;; rather than its string representation. ;; FIXME: This function is much too long, we need to split it up! @@ -1541,7 +1560,6 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (when start (setq doc (copy-sequence args)) (add-text-properties start end (list 'face argument-face) doc)) - (setq doc (eldoc-docstring-format-sym-doc prefix doc)) doc))) ;; Return a string containing a brief (one-line) documentation string for @@ -1554,9 +1572,7 @@ In the absence of INDEX, just call `eldoc-docstring-format-sym-doc'." (t (let ((doc (documentation-property sym 'variable-documentation t))) (when doc - (let ((doc (eldoc-docstring-format-sym-doc - sym (elisp--docstring-first-line doc) - 'font-lock-variable-name-face))) + (let ((doc (elisp--docstring-first-line doc))) (elisp--last-data-store sym doc 'variable))))))) (defun elisp--last-data-store (symbol doc type) diff --git a/lisp/progmodes/etags.el b/lisp/progmodes/etags.el index 897f105019e..edadbbdafc1 100644 --- a/lisp/progmodes/etags.el +++ b/lisp/progmodes/etags.el @@ -2080,8 +2080,8 @@ file name, add `tag-partial-file-name-match-p' to the list value.") (cl-defmethod xref-backend-definitions ((_backend (eql etags)) symbol) (etags--xref-find-definitions symbol)) -(cl-defmethod xref-backend-apropos ((_backend (eql etags)) symbol) - (etags--xref-find-definitions symbol t)) +(cl-defmethod xref-backend-apropos ((_backend (eql etags)) pattern) + (etags--xref-find-definitions (xref-apropos-regexp pattern) t)) (defun etags--xref-find-definitions (pattern &optional regexp?) ;; This emulates the behavior of `find-tag-in-order' but instead of diff --git a/lisp/progmodes/flymake.el b/lisp/progmodes/flymake.el index 1ed733b7e37..37e73241e5d 100644 --- a/lisp/progmodes/flymake.el +++ b/lisp/progmodes/flymake.el @@ -4,9 +4,12 @@ ;; Author: Pavel Kobyakov <pk_at_work@yahoo.com> ;; Maintainer: João Távora <joaotavora@gmail.com> -;; Version: 1.0.8 -;; Package-Requires: ((emacs "26.1")) +;; Version: 1.0.9 ;; Keywords: c languages tools +;; Package-Requires: ((emacs "26.1") (eldoc "1.1.0")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -999,6 +1002,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (add-hook 'after-change-functions 'flymake-after-change-function nil t) (add-hook 'after-save-hook 'flymake-after-save-hook nil t) (add-hook 'kill-buffer-hook 'flymake-kill-buffer-hook nil t) + (add-hook 'eldoc-documentation-functions 'flymake-eldoc-function nil t) ;; If Flymake happened to be alrady already ON, we must cleanup ;; existing diagnostic overlays, lest we forget them by blindly @@ -1016,6 +1020,7 @@ special *Flymake log* buffer." :group 'flymake :lighter (remove-hook 'after-save-hook 'flymake-after-save-hook t) (remove-hook 'kill-buffer-hook 'flymake-kill-buffer-hook t) ;;+(remove-hook 'find-file-hook (function flymake-find-file-hook) t) + (remove-hook 'eldoc-documentation-functions 'flymake-eldoc-function t) (mapc #'delete-overlay (flymake--overlays)) @@ -1083,6 +1088,14 @@ START and STOP and LEN are as in `after-change-functions'." (flymake-mode) (flymake-log :warning "Turned on in `flymake-find-file-hook'"))) +(defun flymake-eldoc-function (report-doc &rest _) + "Document diagnostics at point. +Intended for `eldoc-documentation-functions' (which see)." + (let ((diags (flymake-diagnostics (point)))) + (when diags + (funcall report-doc + (mapconcat #'flymake-diagnostic-text diags "\n"))))) + (defun flymake-goto-next-error (&optional n filter interactive) "Go to Nth next Flymake diagnostic that matches FILTER. Interactively, always move to the next diagnostic. With a prefix diff --git a/lisp/progmodes/fortran.el b/lisp/progmodes/fortran.el index 811951eaaaf..abc860b9478 100644 --- a/lisp/progmodes/fortran.el +++ b/lisp/progmodes/fortran.el @@ -429,7 +429,7 @@ The only difference is, it returns t in a case when the default returns nil." fortran-font-lock-keywords-1 ;; All type specifiers plus their declared items. (list - (list (concat fortran-type-types "[ \t(/]*\\(*\\)?") + (list (concat fortran-type-types "[ \t(/]*\\(\\*\\)?") ;; Type specifier. '(1 font-lock-type-face) ;; Declaration item (or just /.../ block name). diff --git a/lisp/progmodes/gdb-mi.el b/lisp/progmodes/gdb-mi.el index e785acd2840..c1184211d06 100644 --- a/lisp/progmodes/gdb-mi.el +++ b/lisp/progmodes/gdb-mi.el @@ -92,6 +92,8 @@ (require 'json) (require 'bindat) (require 'cl-lib) +(require 'cl-seq) +(eval-when-compile (require 'pcase)) (declare-function speedbar-change-initial-expansion-list "speedbar" (new-default)) @@ -105,13 +107,24 @@ (defvar speedbar-initial-expansion-list-name) (defvar speedbar-frame) -(defvar gdb-memory-address "main") -(defvar gdb-memory-last-address nil +(defvar-local gdb-memory-address-expression "main" + "This expression is passed to gdb. +Possible value: main, $rsp, x+3.") +(defvar-local gdb-memory-address nil + "Address of memory display.") +(defvar-local gdb-memory-last-address nil "Last successfully accessed memory address.") (defvar gdb-memory-next-page nil "Address of next memory page for program memory buffer.") (defvar gdb-memory-prev-page nil "Address of previous memory page for program memory buffer.") +(defvar-local gdb--memory-display-warning nil + "Display warning on memory header if t. + +When error occurs when retrieving memory, gdb-mi displays the +last successful page. In that case the expression might not +match the memory displayed. We want to let the user be aware of +that, so display a warning exclamation mark in the header line.") (defvar gdb-thread-number nil "Main current thread. @@ -211,7 +224,9 @@ Only used for files that Emacs can't find.") (defvar gdb-source-file-list nil "List of source files for the current executable.") (defvar gdb-first-done-or-error t) -(defvar gdb-source-window nil) +(defvar gdb-source-window-list nil + "List of windows used for displaying source files. +Sorted in most-recently-visited-first order.") (defvar gdb-inferior-status nil) (defvar gdb-continuation nil) (defvar gdb-supports-non-stop nil) @@ -242,6 +257,27 @@ Possible values are these symbols: disposition of output generated by commands that gdb mode sends to gdb on its own behalf.") +(defvar gdb--window-configuration-before nil + "Stores the window configuration before starting GDB.") + +(defcustom gdb-restore-window-configuration-after-quit nil + "If non-nil, restore window configuration as of before GDB started. + +Possible values are: + t -- Always restore. + nil -- Don't restore. + `if-gdb-show-main' -- Restore only if variable `gdb-show-main' + is non-nil + `if-gdb-many-windows' -- Restore only if variable `gdb-many-windows' + is non-nil." + :type '(choice + (const :tag "Always restore" t) + (const :tag "Don't restore" nil) + (const :tag "Depends on `gdb-show-main'" 'if-gdb-show-main) + (const :tag "Depends on `gdb-many-windows'" 'if-gdb-many-windows)) + :group 'gdb + :version "28.1") + (defcustom gdb-discard-unordered-replies t "Non-nil means discard any out-of-order GDB replies. This protects against lost GDB replies, assuming that GDB always @@ -592,6 +628,40 @@ Also display the main routine in the disassembly buffer if present." :group 'gdb :version "22.1") +(defcustom gdb-window-configuration-directory user-emacs-directory + "Directory where GDB window configuration files are stored. +If nil, use `default-directory'." + :type 'string + :group 'gdb + :version "28.1") + +(defcustom gdb-default-window-configuration-file nil + "If non-nil, load this window configuration (layout) on startup. +This should be the full name of the window configuration file. +If this is not an absolute path, GDB treats it as a relative path +and looks under `gdb-window-configuration-directory'. + +Note that this variable only takes effect when variable +`gdb-many-windows' is t." + :type 'string + :group 'gdb + :version "28.1") + +(defcustom gdb-display-source-buffer-action '(nil . ((inhibit-same-window . t))) + "`display-buffer' action used when GDB displays a source buffer." + :type 'list + :group 'gdb + :version "28.1") + +(defcustom gdb-max-source-window-count 1 + "Maximum number of source windows to use. +Until there are such number of source windows on screen, GDB +tries to open a new window when visiting a new source file; after +that GDB starts to reuse existing source windows." + :type 'number + :group 'gdb + :version "28.1") + (defvar gdbmi-debug-mode nil "When non-nil, print the messages sent/received from GDB/MI in *Messages*.") @@ -750,6 +820,12 @@ detailed description of this mode. (gdb-restore-windows) (error "Multiple debugging requires restarting in text command mode")) + + ;; Save window configuration before starting gdb so we can restore + ;; it after gdb quits. Save it regardless of the value of + ;; `gdb-restore-window-configuration-after-quit'. + (setq gdb--window-configuration-before (window-state-get)) + ;; (gud-common-init command-line nil 'gud-gdbmi-marker-filter) @@ -925,7 +1001,7 @@ detailed description of this mode. gdb-first-done-or-error t gdb-buffer-fringe-width (car (window-fringes)) gdb-debug-log nil - gdb-source-window nil + gdb-source-window-list nil gdb-inferior-status nil gdb-continuation nil gdb-buf-publisher '() @@ -1035,7 +1111,10 @@ no input, and GDB is waiting for input." (declare-function tooltip-show "tooltip" (text &optional use-echo-area)) -(defconst gdb--string-regexp "\"\\(?:[^\\\"]\\|\\\\.\\)*\"") +(defconst gdb--string-regexp (rx "\"" + (* (or (seq "\\" nonl) + (not (any "\"\\")))) + "\"")) (defun gdb-tooltip-print (expr) (with-current-buffer (gdb-get-buffer 'gdb-partial-output-buffer) @@ -1667,25 +1746,25 @@ this trigger is subscribed to `gdb-buf-publisher' and called with "Interrupt the program being debugged." (interactive) (interrupt-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-quit () "Send quit signal to the program being debugged." (interactive) (quit-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-stop () "Stop the program being debugged." (interactive) (stop-process - (get-buffer-process gud-comint-buffer) comint-ptyp)) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)) comint-ptyp)) (defun gdb-io-eof () "Send end-of-file to the program being debugged." (interactive) (process-send-eof - (get-buffer-process gud-comint-buffer))) + (get-buffer-process (gdb-get-buffer-create 'gdb-inferior-io)))) (defun gdb-clear-inferior-io () (with-current-buffer (gdb-get-buffer-create 'gdb-inferior-io) @@ -1788,7 +1867,8 @@ static char *magick[] = { "\\|def\\(i\\(ne?\\)?\\)?\\|doc\\(u\\(m\\(e\\(nt?\\)?\\)?\\)?\\)?\\|" gdb-python-guile-commands-regexp "\\|while-stepping\\|stepp\\(i\\(ng?\\)?\\)?\\|ws\\|actions" - "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)?$") + "\\|expl\\(o\\(re?\\)?\\)?" + "\\)\\([[:blank:]]+\\([^[:blank:]]*\\)\\)*$") "Regexp matching GDB commands that enter a recursive reading loop. As long as GDB is in the recursive reading loop, it does not expect commands to be prefixed by \"-interpreter-exec console\".") @@ -2007,17 +2087,36 @@ is running." ;; GDB frame (after up, down etc). If no GDB frame is visible but the last ;; visited breakpoint is, use that window. (defun gdb-display-source-buffer (buffer) - (let* ((last-window (if gud-last-last-frame - (get-buffer-window - (gud-find-file (car gud-last-last-frame))))) - (source-window (or last-window - (if (and gdb-source-window - (window-live-p gdb-source-window)) - gdb-source-window)))) - (when source-window - (setq gdb-source-window source-window) - (set-window-buffer source-window buffer)) - source-window)) + "Find a window to display BUFFER. +Always find a window to display buffer, and return it." + ;; This function doesn't take care of setting up source window(s) at startup, + ;; that's handled by `gdb-setup-windows' (if `gdb-many-windows' is non-nil). + ;; If `buffer' is already shown in a window, use that window. + (or (get-buffer-window buffer) + (progn + ;; First, update the window list. + (setq gdb-source-window-list + (cl-remove-duplicates + (cl-remove-if-not + (lambda (win) + (and (window-live-p win) + (eq (window-frame win) + (selected-frame)))) + gdb-source-window-list))) + ;; Should we create a new window or reuse one? + (if (> gdb-max-source-window-count + (length gdb-source-window-list)) + ;; Create a new window, push it to window list and return it. + (car (push (display-buffer buffer gdb-display-source-buffer-action) + gdb-source-window-list)) + ;; Reuse a window, we use the oldest window and put that to + ;; the front of the window list. + (let ((last-win (car (last gdb-source-window-list))) + (rest (butlast gdb-source-window-list))) + (set-window-buffer last-win buffer) + (setq gdb-source-window-list + (cons last-win rest)) + last-win))))) (defun gdbmi-start-with (str offset match) @@ -2446,7 +2545,13 @@ file names include non-ASCII characters." gdb-filter-output) -(defun gdb-gdb (_output-field)) +(defun gdb-gdb (_output-field) + ;; This is needed because the "explore" command is not ended by the + ;; likes of "end" or "quit", but instead by a RET at the approriate + ;; place, and we know we have exited "explore" when we get the + ;; "(gdb)" prompt. + (and (> gdb-control-level 0) + (setq gdb-control-level (1- gdb-control-level)))) (defun gdb-shell (output-field) (setq gdb-filter-output @@ -3450,7 +3555,7 @@ line." (def-gdb-trigger-and-handler gdb-invalidate-memory (format "-data-read-memory %s %s %d %d %d" - gdb-memory-address + (gdb-mi-quote gdb-memory-address-expression) gdb-memory-format gdb-memory-unit gdb-memory-rows @@ -3490,6 +3595,9 @@ in `gdb-memory-format'." (err-msg (bindat-get-field res 'msg))) (if (not err-msg) (let ((memory (bindat-get-field res 'memory))) + (when gdb-memory-last-address + ;; Nil means last retrieve emits error or just started the session. + (setq gdb--memory-display-warning nil)) (setq gdb-memory-address (bindat-get-field res 'addr)) (setq gdb-memory-next-page (bindat-get-field res 'next-page)) (setq gdb-memory-prev-page (bindat-get-field res 'prev-page)) @@ -3503,10 +3611,15 @@ in `gdb-memory-format'." gdb-memory-format))))) (newline))) ;; Show last page instead of empty buffer when out of bounds - (progn - (let ((gdb-memory-address gdb-memory-last-address)) + (when gdb-memory-last-address + (let ((gdb-memory-address-expression gdb-memory-last-address)) + ;; If we don't set `gdb-memory-last-address' to nil, + ;; `gdb-invalidate-memory' eventually calls + ;; `gdb-read-memory-custom', making an infinite loop. + (setq gdb-memory-last-address nil + gdb--memory-display-warning t) (gdb-invalidate-memory 'update) - (error err-msg)))))) + (user-error "Error when retrieving memory: %s Displaying last successful page" err-msg)))))) (defvar gdb-memory-mode-map (let ((map (make-sparse-keymap))) @@ -3540,7 +3653,7 @@ in `gdb-memory-format'." "Set the start memory address." (interactive) (let ((arg (read-from-minibuffer "Memory address: "))) - (setq gdb-memory-address arg)) + (setq gdb-memory-address-expression arg)) (gdb-invalidate-memory 'update)) (defmacro def-gdb-set-positive-number (name variable echo-string &optional doc) @@ -3723,7 +3836,19 @@ DOC is an optional documentation string." (defvar gdb-memory-header '(:eval (concat - "Start address[" + "Start address " + ;; If `gdb-memory-address-expression' is nil, `propertize' would error. + (propertize (or gdb-memory-address-expression "N/A") + 'face font-lock-warning-face + 'help-echo "mouse-1: set start address" + 'mouse-face 'mode-line-highlight + 'local-map (gdb-make-header-line-mouse-map + 'mouse-1 + #'gdb-memory-set-address-event)) + (if gdb--memory-display-warning + (propertize " !" 'face '(:inherit error :weight bold)) + "") + " [" (propertize "-" 'face font-lock-warning-face 'help-echo "mouse-1: decrement address" @@ -3740,13 +3865,9 @@ DOC is an optional documentation string." 'mouse-1 #'gdb-memory-show-next-page)) "]: " - (propertize gdb-memory-address - 'face font-lock-warning-face - 'help-echo "mouse-1: set start address" - 'mouse-face 'mode-line-highlight - 'local-map (gdb-make-header-line-mouse-map - 'mouse-1 - #'gdb-memory-set-address-event)) + ;; If `gdb-memory-address' is nil, `propertize' would error. + (propertize (or gdb-memory-address "N/A") + 'face font-lock-warning-face) " Rows: " (propertize (number-to-string gdb-memory-rows) 'face font-lock-warning-face @@ -3986,9 +4107,7 @@ DOC is an optional documentation string." (let* ((buffer (find-file-noselect (if (file-exists-p file) file (cdr (assoc bptno gdb-location-alist))))) - (window (or (gdb-display-source-buffer buffer) - (display-buffer buffer)))) - (setq gdb-source-window window) + (window (gdb-display-source-buffer buffer))) (with-current-buffer buffer (goto-char (point-min)) (forward-line (1- (string-to-number line))) @@ -4464,6 +4583,26 @@ SPLIT-HORIZONTAL and show BUF in the new window." (define-key gud-menu-map [displays] `(menu-item "GDB-Windows" ,menu :visible (eq gud-minor-mode 'gdbmi))) + (define-key menu [gdb-restore-windows] + '(menu-item "Restore Initial Layout" gdb-restore-windows + :help "Restore the initial GDB window layout.")) + ;; Window layout vs window configuration: We use "window layout" in + ;; GDB UI. Internally we refer to "window configuration" because + ;; that's the data structure used to store window layouts. Though + ;; bare in mind that there is a small difference between what we + ;; store and what normal window configuration functions + ;; output. Because GDB buffers (source, local, breakpoint, etc) are + ;; different between each debugging sessions, simply save/load + ;; window configurations doesn't + ;; work. `gdb-save-window-configuration' and + ;; `gdb-load-window-configuration' do some tricks to store and + ;; recreate each buffer in the layout. + (define-key menu [load-layout] '("Load Layout" "Load GDB window configuration (layout) from a file" . gdb-load-window-configuration)) + (define-key menu [save-layout] '("Save Layout" "Save current GDB window configuration (layout) to a file" . gdb-save-window-configuration)) + (define-key menu [restore-layout-after-quit] + '(menu-item "Restore Layout After Quit" gdb-toggle-restore-window-configuration + :button (:toggle . gdb-restore-window-configuration-after-quit) + :help "Toggle between always restore the window configuration (layout) after GDB quits and never restore.\n You can also change this setting in Customize to conditionally restore.")) (define-key menu [gdb] '("Gdb" . gdb-display-gdb-buffer)) (define-key menu [threads] '("Threads" . gdb-display-threads-buffer)) (define-key menu [memory] '("Memory" . gdb-display-memory-buffer)) @@ -4502,9 +4641,6 @@ SPLIT-HORIZONTAL and show BUF in the new window." '(menu-item "Display Other Windows" gdb-many-windows :help "Toggle display of locals, stack and breakpoint information" :button (:toggle . gdb-many-windows))) - (define-key menu [gdb-restore-windows] - '(menu-item "Restore Window Layout" gdb-restore-windows - :help "Restore standard layout for debug session.")) (define-key menu [sep1] '(menu-item "--")) (define-key menu [all-threads] @@ -4579,41 +4715,173 @@ window is dedicated." (set-window-buffer window (get-buffer name)) (set-window-dedicated-p window t)) +(defun gdb-toggle-restore-window-configuration () + "Toggle whether to restore window configuration when GDB quits." + (interactive) + (setq gdb-restore-window-configuration-after-quit + (not gdb-restore-window-configuration-after-quit))) + +(defun gdb-get-source-buffer () + "Return a buffer displaying source file or nil if we can't find one. +The source file is the file that contains the source location +where GDB stops. There could be multiple source files during a +debugging session, we get the most recently showed one. If +program hasn't started running yet, the source file is the \"main +file\" where the GDB session starts (see `gdb-main-file')." + (if gud-last-last-frame + (gud-find-file (car gud-last-last-frame)) + (when gdb-main-file + (gud-find-file gdb-main-file)))) + (defun gdb-setup-windows () - "Layout the window pattern for option `gdb-many-windows'." - (gdb-get-buffer-create 'gdb-locals-buffer) - (gdb-get-buffer-create 'gdb-stack-buffer) - (gdb-get-buffer-create 'gdb-breakpoints-buffer) - (set-window-dedicated-p (selected-window) nil) - (switch-to-buffer gud-comint-buffer) - (delete-other-windows) - (let ((win0 (selected-window)) - (win1 (split-window nil ( / ( * (window-height) 3) 4))) - (win2 (split-window nil ( / (window-height) 3))) - (win3 (split-window-right))) - (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3) - (select-window win2) - (set-window-buffer - win2 - (if gud-last-last-frame - (gud-find-file (car gud-last-last-frame)) - (if gdb-main-file - (gud-find-file gdb-main-file) - ;; Put buffer list in window if we - ;; can't find a source file. - (list-buffers-noselect)))) - (setq gdb-source-window (selected-window)) - (let ((win4 (split-window-right))) - (gdb-set-window-buffer - (gdb-get-buffer-create 'gdb-inferior-io) nil win4)) - (select-window win1) - (gdb-set-window-buffer (gdb-stack-buffer-name)) - (let ((win5 (split-window-right))) - (gdb-set-window-buffer (if gdb-show-threads-by-default - (gdb-threads-buffer-name) - (gdb-breakpoints-buffer-name)) - nil win5)) - (select-window win0))) + "Lay out the window pattern for option `gdb-many-windows'." + (if gdb-default-window-configuration-file + (gdb-load-window-configuration + (if (file-name-absolute-p gdb-default-window-configuration-file) + gdb-default-window-configuration-file + (expand-file-name gdb-default-window-configuration-file + gdb-window-configuration-directory))) + ;; Create default layout as before. + (gdb-get-buffer-create 'gdb-locals-buffer) + (gdb-get-buffer-create 'gdb-stack-buffer) + (gdb-get-buffer-create 'gdb-breakpoints-buffer) + (set-window-dedicated-p (selected-window) nil) + (switch-to-buffer gud-comint-buffer) + (delete-other-windows) + (let ((win0 (selected-window)) + (win1 (split-window nil ( / ( * (window-height) 3) 4))) + (win2 (split-window nil ( / (window-height) 3))) + (win3 (split-window-right))) + (gdb-set-window-buffer (gdb-locals-buffer-name) nil win3) + (select-window win2) + (set-window-buffer win2 (or (gdb-get-source-buffer) + (list-buffers-noselect))) + (setq gdb-source-window-list (list (selected-window))) + (let ((win4 (split-window-right))) + (gdb-set-window-buffer + (gdb-get-buffer-create 'gdb-inferior-io) nil win4)) + (select-window win1) + (gdb-set-window-buffer (gdb-stack-buffer-name)) + (let ((win5 (split-window-right))) + (gdb-set-window-buffer (if gdb-show-threads-by-default + (gdb-threads-buffer-name) + (gdb-breakpoints-buffer-name)) + nil win5)) + (select-window win0)))) + +(defun gdb-buffer-p (buffer) + "Return t if BUFFER is GDB-related." + (with-current-buffer buffer + (eq gud-minor-mode 'gdbmi))) + +(defun gdb-function-buffer-p (buffer) + "Return t if BUFFER is a GDB function buffer. + +Function buffers are locals buffer, registers buffer, etc, but +not including main command buffer (the one where you type GDB +commands) or source buffers (that display program source code)." + (with-current-buffer buffer + (derived-mode-p 'gdb-parent-mode 'gdb-inferior-io-mode))) + +(defun gdb--buffer-type (buffer) + "Return the type of BUFFER if it is a function buffer. +Buffer type is like `gdb-registers-type', `gdb-stack-buffer'. +These symbols are used by `gdb-get-buffer-create'. + +Return nil if BUFFER is not a GDB function buffer." + (with-current-buffer buffer + (cl-loop for rule in gdb-buffer-rules + for mode-name = (gdb-rules-buffer-mode rule) + for type = (car rule) + if (eq mode-name major-mode) + return type + finally return nil))) + +(defun gdb-save-window-configuration (file) + "Save current window configuration (layout) to FILE. +You can later restore this configuration from that file by +`gdb-load-window-configuration'." + (interactive (list (read-file-name + "Save window configuration to file: " + (or gdb-window-configuration-directory + default-directory)))) + ;; We replace the buffer in each window with a placeholder, store + ;; the buffer type (register, breakpoint, etc) in window parameters, + ;; and write the window configuration to the file. + (save-window-excursion + (let ((placeholder (get-buffer-create " *gdb-placeholder*")) + (window-persistent-parameters + (cons '(gdb-buffer-type . writable) window-persistent-parameters))) + (unwind-protect + (dolist (win (window-list nil 'no-minibuffer)) + (select-window win) + (when (gdb-buffer-p (current-buffer)) + (set-window-parameter + nil 'gdb-buffer-type + (cond ((gdb-function-buffer-p (current-buffer)) + ;; 1) If a user arranged the window + ;; configuration herself and saves it, windows + ;; are probably not dedicated. 2) We use the + ;; same dedication flag as in + ;; `gdb-display-buffer'. + (set-window-dedicated-p nil t) + ;; We save this gdb-buffer-type symbol so + ;; we can later pass it to `gdb-get-buffer-create'; + ;; one example: `gdb-registers-buffer'. + (or (gdb--buffer-type (current-buffer)) + (error "Unrecognized gdb buffer mode: %s" major-mode))) + ;; Command buffer. + ((derived-mode-p 'gud-mode) 'command) + ;; Consider everything else as source buffer. + (t 'source))) + (with-window-non-dedicated nil + (set-window-buffer nil placeholder) + (set-window-prev-buffers (selected-window) nil) + (set-window-next-buffers (selected-window) nil)))) + ;; Save the window configuration to FILE. + (let ((window-config (window-state-get nil t))) + (with-temp-buffer + (prin1 window-config (current-buffer)) + (write-file file t))) + (kill-buffer placeholder))))) + +(defun gdb-load-window-configuration (file) + "Restore window configuration (layout) from FILE. +FILE should be a window configuration file saved by +`gdb-save-window-configuration'." + (interactive (list (read-file-name + "Restore window configuration from file: " + (or gdb-window-configuration-directory + default-directory)))) + ;; Basically, we restore window configuration and go through each + ;; window and restore the function buffers. + (let* ((placeholder (get-buffer-create " *gdb-placeholder*"))) + (unwind-protect ; Don't leak buffer. + (let ((window-config (with-temp-buffer + (insert-file-contents file) + ;; We need to go to point-min because + ;; `read' reads from point + (goto-char (point-min)) + (read (current-buffer)))) + (source-buffer (or (gdb-get-source-buffer) + ;; Do the same thing as in + ;; `gdb-setup-windows' if no source + ;; buffer is found. + (list-buffers-noselect))) + buffer-type) + (window-state-put window-config (frame-root-window)) + (dolist (window (window-list nil 'no-minibuffer)) + (with-selected-window window + (setq buffer-type (window-parameter nil 'gdb-buffer-type)) + (pcase buffer-type + ('source (when source-buffer + (set-window-buffer nil source-buffer) + (push (selected-window) gdb-source-window-list))) + ('command (switch-to-buffer gud-comint-buffer)) + (_ (let ((buffer (gdb-get-buffer-create buffer-type))) + (with-window-non-dedicated nil + (set-window-buffer nil buffer)))))))) + (kill-buffer placeholder)))) (define-minor-mode gdb-many-windows "If nil just pop up the GUD buffer unless `gdb-show-main' is t. @@ -4631,7 +4899,12 @@ of the debugged program. Non-nil means display the layout shown for (defun gdb-restore-windows () "Restore the basic arrangement of windows used by gdb. -This arrangement depends on the value of option `gdb-many-windows'." +This arrangement depends on the values of variable +`gdb-many-windows' and `gdb-default-window-configuration-file'." + ;; This function is used when the user messed up window + ;; configuration and wants to "reset to default". The function that + ;; sets up window configuration on start up is + ;; `gdb-get-source-file'. (interactive) (switch-to-buffer gud-comint-buffer) ;Select the right window and frame. (delete-other-windows) @@ -4644,7 +4917,7 @@ This arrangement depends on the value of option `gdb-many-windows'." (if gud-last-last-frame (gud-find-file (car gud-last-last-frame)) (gud-find-file gdb-main-file))) - (setq gdb-source-window win))))) + (setq gdb-source-window-list (list win)))))) ;; Called from `gud-sentinel' in gud.el: (defun gdb-reset () @@ -4678,11 +4951,25 @@ Kills the gdb buffers, and resets variables and the source buffers." (if (boundp 'speedbar-frame) (speedbar-timer-fn)) (setq gud-running nil) (setq gdb-active-process nil) - (remove-hook 'after-save-hook 'gdb-create-define-alist t)) + (remove-hook 'after-save-hook 'gdb-create-define-alist t) + ;; Recover window configuration. + (when (or (eq gdb-restore-window-configuration-after-quit t) + (and (eq gdb-restore-window-configuration-after-quit + 'if-gdb-show-main) + gdb-show-main) + (and (eq gdb-restore-window-configuration-after-quit + 'if-gdb-many-windows) + gdb-many-windows)) + (when gdb--window-configuration-before + (window-state-put gdb--window-configuration-before) + ;; This way we don't accidentally restore an outdated window + ;; configuration. + (setq gdb--window-configuration-before nil)))) (defun gdb-get-source-file () "Find the source file where the program starts and display it with related buffers, if required." + ;; This function is called only once on startup. (goto-char (point-min)) (if (re-search-forward gdb-source-file-regexp nil t) (setq gdb-main-file (read (match-string 1)))) diff --git a/lisp/progmodes/glasses.el b/lisp/progmodes/glasses.el index cad74f9f63a..ab65a1590c0 100644 --- a/lisp/progmodes/glasses.el +++ b/lisp/progmodes/glasses.el @@ -1,4 +1,4 @@ -;;; glasses.el --- make cantReadThis readable +;;; glasses.el --- make cantReadThis readable -*- lexical-binding: t; -*- ;; Copyright (C) 1999-2020 Free Software Foundation, Inc. @@ -66,7 +66,6 @@ defined by `glasses-original-separator'. If you don't want to add missing separators, set `glasses-separator' to an empty string. If you don't want to replace existent separators, set `glasses-original-separator' to an empty string." - :group 'glasses :type 'string :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -78,7 +77,6 @@ For instance, if you set it to \"_\" and set `glasses-separator' to \"-\", underscore separators are displayed as hyphens. If `glasses-original-separator' is an empty string, no such display change is performed." - :group 'glasses :type 'string :set 'glasses-custom-set :initialize 'custom-initialize-default @@ -92,7 +90,6 @@ If it is nil, no face is placed at the capitalized letter. For example, you can set `glasses-separator' to an empty string and `glasses-face' to `bold'. Then unreadable identifiers will have no separators, but will have their capitals in bold." - :group 'glasses :type '(choice (const :tag "None" nil) face) :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -100,7 +97,6 @@ but will have their capitals in bold." (defcustom glasses-separate-parentheses-p t "If non-nil, ensure space between an identifier and an opening parenthesis." - :group 'glasses :type 'boolean) (defcustom glasses-separate-parentheses-exceptions @@ -108,7 +104,6 @@ but will have their capitals in bold." "List of regexp that are exceptions for `glasses-separate-parentheses-p'. They are matched to the current line truncated to the point where the parenthesis expression starts." - :group 'glasses :type '(repeat regexp)) (defcustom glasses-separate-capital-groups t @@ -116,7 +111,6 @@ parenthesis expression starts." When the value is non-nil, HTMLSomething and IPv6 are displayed as HTML_Something and I_Pv6 respectively. Set the value to nil if you prefer to display them unchanged." - :group 'glasses :type 'boolean :version "24.1") @@ -124,7 +118,6 @@ if you prefer to display them unchanged." "If non-nil, downcase embedded capital letters in identifiers. Only identifiers starting with lower case letters are affected, letters inside other identifiers are unchanged." - :group 'glasses :type 'boolean :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -135,7 +128,6 @@ other identifiers are unchanged." Only words starting with this regexp are uncapitalized. The regexp is case sensitive. It has any effect only when `glasses-uncapitalize-p' is non-nil." - :group 'glasses :type 'regexp :set 'glasses-custom-set :initialize 'custom-initialize-default) @@ -149,7 +141,6 @@ file write then. Note the removal action does not try to be much clever, so it can remove real separators too." - :group 'glasses :type 'boolean) diff --git a/lisp/progmodes/grep.el b/lisp/progmodes/grep.el index d4aca28bd7c..7731be59659 100644 --- a/lisp/progmodes/grep.el +++ b/lisp/progmodes/grep.el @@ -64,8 +64,7 @@ SYMBOL should be one of `grep-command', `grep-template', "Number of lines in a grep window. If nil, use `compilation-window-height'." :type '(choice (const :tag "Default" nil) integer) - :version "22.1" - :group 'grep) + :version "22.1") (defcustom grep-highlight-matches 'auto-detect "Use special markers to highlight grep matches. @@ -98,9 +97,8 @@ To change the default value, use \\[customize] or call the function (const :tag "Use --color=always" always) (const :tag "Use --color" auto) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-scroll-output nil "Non-nil to scroll the *grep* buffer window as output appears. @@ -109,8 +107,7 @@ Setting it causes the grep commands to put point at the end of their output window so that the end of the output is always visible rather than the beginning." :type 'boolean - :version "22.1" - :group 'grep) + :version "22.1") ;;;###autoload (defcustom grep-command nil @@ -124,8 +121,7 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-template nil "The default command to run for \\[lgrep]. @@ -141,9 +137,8 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-use-null-device 'auto-detect "If t, append the value of `null-device' to `grep' commands. @@ -157,8 +152,7 @@ by `grep-compute-defaults'; to change the default value, use :type '(choice (const :tag "Do Not Append Null Device" nil) (const :tag "Append Null Device" t) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-use-null-filename-separator 'auto-detect "If non-nil, use `grep's `--null' option. @@ -167,8 +161,7 @@ This is done to disambiguate file names in `grep's output." :type '(choice (const :tag "Do Not Use `--null'" nil) (const :tag "Use `--null'" t) (other :tag "Not Set" auto-detect)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) ;;;###autoload (defcustom grep-find-command nil @@ -178,8 +171,7 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :group 'grep) + :set #'grep-apply-setting) (defcustom grep-find-template nil "The default command to run for \\[rgrep]. @@ -194,9 +186,8 @@ by `grep-compute-defaults'; to change the default value, use \\[customize] or call the function `grep-apply-setting'." :type '(choice string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "22.1" - :group 'grep) + :set #'grep-apply-setting + :version "22.1") (defcustom grep-files-aliases '(("all" . "* .[!.]* ..?*") ;; Don't match `..'. See bug#22577 @@ -213,8 +204,7 @@ by `grep-compute-defaults'; to change the default value, use ("texi" . "*.texi") ("asm" . "*.[sS]")) "Alist of aliases for the FILES argument to `lgrep' and `rgrep'." - :type 'alist - :group 'grep) + :type 'alist) (defcustom grep-find-ignored-directories vc-directory-exclusion-list "List of names of sub-directories which `rgrep' shall not recurse into. @@ -223,8 +213,7 @@ to determine whether cdr should not be recursed into. The default value is inherited from `vc-directory-exclusion-list'." :type '(choice (repeat :tag "Ignored directories" string) - (const :tag "No ignored directories" nil)) - :group 'grep) + (const :tag "No ignored directories" nil))) (defcustom grep-find-ignored-files (cons ".#*" (delq nil (mapcar (lambda (s) @@ -235,8 +224,7 @@ The default value is inherited from `vc-directory-exclusion-list'." If an element is a cons cell, the car is called on the search directory to determine whether cdr should not be excluded." :type '(choice (repeat :tag "Ignored file" string) - (const :tag "No ignored files" nil)) - :group 'grep) + (const :tag "No ignored files" nil))) (defcustom grep-save-buffers 'ask "If non-nil, save buffers before running the grep commands. @@ -251,22 +239,19 @@ to limit saving to files located under `my-grep-root'." (const :tag "Ask before saving" ask) (const :tag "Don't save buffers" nil) function - (other :tag "Save all buffers" t)) - :group 'grep) + (other :tag "Save all buffers" t))) (defcustom grep-error-screen-columns nil "If non-nil, column numbers in grep hits are screen columns. See `compilation-error-screen-columns'." :type '(choice (const :tag "Default" nil) integer) - :version "22.1" - :group 'grep) + :version "22.1") ;;;###autoload (defcustom grep-setup-hook nil "List of hook functions run by `grep-process-setup' (see `run-hooks')." - :type 'hook - :group 'grep) + :type 'hook) (defvar grep-mode-map (let ((map (make-sparse-keymap))) @@ -333,7 +318,10 @@ See `compilation-error-screen-columns'." ;; When bootstrapping, tool-bar-map is not properly initialized yet, ;; so don't do anything. (when (keymapp (butlast tool-bar-map)) + ;; We have to `copy-keymap' rather than use keymap inheritance because + ;; we want to put the new items at the *end* of the tool-bar. (let ((map (butlast (copy-keymap tool-bar-map))) + ;; FIXME: Nowadays the last button is not "help" but "search"! (help (last tool-bar-map))) ;; Keep Help last in tool bar (tool-bar-local-item "left-arrow" 'previous-error-no-select 'previous-error-no-select map @@ -439,15 +427,13 @@ and reveals the entire command line. The visibility of the abbreviated part can also be toggled with `grep-find-toggle-abbreviation'." :type 'boolean - :version "27.1" - :group 'grep) + :version "27.1") (defcustom grep-search-path '(nil) "List of directories to search for files named in grep messages. Elements should be directory names, not file names of directories. The value nil as an element means the grep messages buffer `default-directory'." - :group 'grep :version "27.1" :type '(repeat (choice (const :tag "Default" nil) (string :tag "Directory")))) @@ -528,9 +514,8 @@ This variable's value takes effect when `grep-compute-defaults' is called." (const :tag "find -print0 | sort -z | xargs -0'" gnu-sort) string (const :tag "Not Set" nil)) - :set 'grep-apply-setting - :version "27.1" - :group 'grep) + :set #'grep-apply-setting + :version "27.1") ;; History of grep commands. ;;;###autoload @@ -562,7 +547,7 @@ Set up `compilation-exit-message-function' and run `grep-setup-hook'." (setenv "GREP_COLORS" "mt=01;31:fn=:ln=:bn=:se=:sl=:cx=:ne")) (setq-local grep-num-matches-found 0) (set (make-local-variable 'compilation-exit-message-function) - 'grep-exit-message) + #'grep-exit-message) (run-hooks 'grep-setup-hook)) (defun grep-exit-message (status code msg) @@ -612,7 +597,7 @@ This function is called from `compilation-filter-hook'." (defun grep-probe (command args &optional func result) (let (process-file-side-effects) (equal (condition-case nil - (apply (or func 'process-file) command args) + (apply (or func #'process-file) command args) (error nil)) (or result 0)))) @@ -808,7 +793,7 @@ The value depends on `grep-command', `grep-template', (buffer-substring-no-properties (point) (mark))) (funcall (or find-tag-default-function (get major-mode 'find-tag-default-function) - 'find-tag-default)) + #'find-tag-default)) "")) (defun grep-default-command () @@ -863,11 +848,11 @@ The value depends on `grep-command', `grep-template', (set (make-local-variable 'compilation-directory-matcher) (list regexp-unmatchable)) (set (make-local-variable 'compilation-process-setup-function) - 'grep-process-setup) + #'grep-process-setup) (set (make-local-variable 'compilation-disable-input) t) (set (make-local-variable 'compilation-error-screen-columns) grep-error-screen-columns) - (add-hook 'compilation-filter-hook 'grep-filter nil t)) + (add-hook 'compilation-filter-hook #'grep-filter nil t)) (defun grep--save-buffers () (when grep-save-buffers @@ -914,7 +899,7 @@ list is empty)." (compilation-start (if (and grep-use-null-device null-device) (concat command-args " " null-device) command-args) - 'grep-mode)) + #'grep-mode)) ;;;###autoload @@ -993,23 +978,31 @@ these include `opts', `dir', `files', `null-device', `excl' and "Read regexp arg for interactive grep using `read-regexp'." (read-regexp "Search for" 'grep-tag-default 'grep-regexp-history)) +(defvar grep-read-files-function #'grep-read-files--default) + +(defun grep-read-files--default () + ;; Instead of a `grep-read-files-function' variable, we used to lookup + ;; mode-specific functions in the major mode's symbol properties, so preserve + ;; this behavior for backward compatibility. + (let ((old-function (get major-mode 'grep-read-files))) ;Obsolete since 28.1 + (if old-function + (funcall old-function) + (let ((file-name-at-point + (run-hook-with-args-until-success 'file-name-at-point-functions))) + (or (if (and (stringp file-name-at-point) + (not (file-directory-p file-name-at-point))) + file-name-at-point) + (buffer-file-name) + (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))))) + (defun grep-read-files (regexp) "Read a file-name pattern arg for interactive grep. -The pattern can include shell wildcards. As whitespace triggers +The pattern can include shell wildcards. As SPC can triggers completion when entering a pattern, including it requires quoting, e.g. `\\[quoted-insert]<space>'. REGEXP is used as a string in the prompt." - (let* ((grep-read-files-function (get major-mode 'grep-read-files)) - (file-name-at-point - (run-hook-with-args-until-success 'file-name-at-point-functions)) - (bn (if grep-read-files-function - (funcall grep-read-files-function) - (or (if (and (stringp file-name-at-point) - (not (file-directory-p file-name-at-point))) - file-name-at-point) - (buffer-file-name) - (replace-regexp-in-string "<[0-9]+>\\'" "" (buffer-name))))) + (let* ((bn (funcall grep-read-files-function)) (fn (and bn (stringp bn) (file-name-nondirectory bn))) @@ -1022,7 +1015,7 @@ REGEXP is used as a string in the prompt." (setq alias (car aliases) aliases (cdr aliases)) (if (string-match (mapconcat - 'wildcard-to-regexp + #'wildcard-to-regexp (split-string (cdr alias) nil t) "\\|") fn) @@ -1043,11 +1036,11 @@ REGEXP is used as a string in the prompt." "\" in files matching wildcard" (if default (concat " (default " default ")")) ": ") - 'read-file-name-internal + #'read-file-name-internal nil nil nil 'grep-files-history (delete-dups (delq nil (append (list default default-alias default-extension) - (mapcar 'car grep-files-aliases))))))) + (mapcar #'car grep-files-aliases))))))) (and files (or (cdr (assoc files grep-files-aliases)) files)))) diff --git a/lisp/progmodes/gud.el b/lisp/progmodes/gud.el index 540bc9ce7f3..092d15983e5 100644 --- a/lisp/progmodes/gud.el +++ b/lisp/progmodes/gud.el @@ -486,9 +486,8 @@ The value t means that there is no stack, and we are in display-file mode.") "Additional menu items to add to the speedbar frame.") ;; Make sure our special speedbar mode is loaded -(if (featurep 'speedbar) - (gud-install-speedbar-variables) - (add-hook 'speedbar-load-hook 'gud-install-speedbar-variables)) +(with-eval-after-load 'speedbar + (gud-install-speedbar-variables)) (defun gud-expansion-speedbar-buttons (_directory _zero) "Wrapper for call to `speedbar-add-expansion-list'. @@ -2827,9 +2826,13 @@ Obeying it means displaying in another window the specified file and line." (buffer (with-current-buffer gud-comint-buffer (gud-find-file true-file))) - (window (and buffer - (or (get-buffer-window buffer) - (display-buffer buffer '(nil (inhibit-same-window . t)))))) + (window + (when buffer + (if (eq gud-minor-mode 'gdbmi) + (gdb-display-source-buffer buffer) + ;; Gud still has the old behavior. + (or (get-buffer-window buffer) + (display-buffer buffer '(nil (inhibit-same-window . t))))))) (pos)) (when buffer (with-current-buffer buffer @@ -2859,9 +2862,7 @@ Obeying it means displaying in another window the specified file and line." (widen) (goto-char pos)))) (when window - (set-window-point window gud-overlay-arrow-position) - (if (eq gud-minor-mode 'gdbmi) - (setq gdb-source-window window)))))) + (set-window-point window gud-overlay-arrow-position))))) ;; The gud-call function must do the right thing whether its invoking ;; keystroke is from the GUD buffer itself (via major-mode binding) diff --git a/lisp/progmodes/hideif.el b/lisp/progmodes/hideif.el index 10416ead603..0b1ba80edcb 100644 --- a/lisp/progmodes/hideif.el +++ b/lisp/progmodes/hideif.el @@ -162,7 +162,7 @@ This behavior is generally undesirable. If this option is non-nil, the outermos "\\.h\\(h\\|xx\\|pp\\|\\+\\+\\)?\\'" "C/C++ header file name patterns to determine if current buffer is a header. Effective only if `hide-ifdef-expand-reinclusion-protection' is t." - :type 'string + :type 'regexp :version "25.1") (defvar hide-ifdef-mode-submap diff --git a/lisp/progmodes/idlw-help.el b/lisp/progmodes/idlw-help.el index 69385d7060f..d3a2308e06b 100644 --- a/lisp/progmodes/idlw-help.el +++ b/lisp/progmodes/idlw-help.el @@ -182,14 +182,14 @@ definition is displayed instead." which specifies the `name' section. Can be used for localization support." :group 'idlwave-online-help - :type 'string) + :type 'regexp) (defcustom idlwave-help-doclib-keyword "KEYWORD" "A regexp for the heading word to search for in doclib headers which specifies the `keywords' section. Can be used for localization support." :group 'idlwave-online-help - :type 'string) + :type 'regexp) (defface idlwave-help-link '((t :inherit link)) diff --git a/lisp/progmodes/idlw-shell.el b/lisp/progmodes/idlw-shell.el index dba70cb2821..6770fbe8abc 100644 --- a/lisp/progmodes/idlw-shell.el +++ b/lisp/progmodes/idlw-shell.el @@ -1598,7 +1598,7 @@ number.") "A regular expression to match any IDL error.") (defvar idlwave-shell-halting-error - "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+\\s-*.*\\)\n" + "^% .*\n\\([^%].*\n\\)*% Execution halted at:\\(\\s-*\\S-+\\s-*[0-9]+.*\\)\n" "A regular expression to match errors which halt execution.") (defvar idlwave-shell-cant-continue-error diff --git a/lisp/progmodes/idlwave.el b/lisp/progmodes/idlwave.el index 2601c2e1653..3092d4c45b0 100644 --- a/lisp/progmodes/idlwave.el +++ b/lisp/progmodes/idlwave.el @@ -314,7 +314,7 @@ split then a terminal beep and warning are issued." expression will not be changed. Note that the indentation of a comment at the beginning of a line is never changed." :group 'idlwave-code-formatting - :type 'string) + :type 'regexp) (defcustom idlwave-begin-line-comment nil "A comment anchored at the beginning of line. @@ -1096,6 +1096,8 @@ class-arrows Object Arrows with class property" "Normal hook. Executed when idlwave.el is loaded." :group 'idlwave-misc :type 'hook) +(make-obsolete-variable 'idlwave-load-hook + "use `with-eval-after-load' instead." "28.1") (defvar idlwave-experimental nil "Non-nil means turn on a few experimental features. @@ -1870,7 +1872,6 @@ The main features of this mode are 8. Hooks ----- - Loading idlwave.el runs `idlwave-load-hook'. Turning on `idlwave-mode' runs `idlwave-mode-hook'. 9. Documentation and Customization diff --git a/lisp/progmodes/inf-lisp.el b/lisp/progmodes/inf-lisp.el index a24b94073fc..9f34a377f4a 100644 --- a/lisp/progmodes/inf-lisp.el +++ b/lisp/progmodes/inf-lisp.el @@ -130,9 +130,8 @@ mode. Default is whitespace followed by 0 or 1 single-letter colon-keyword ;;; "This function binds many inferior-lisp commands to C-c <letter> bindings, ;;;where they are more accessible. C-c <letter> bindings are reserved for the -;;;user, so these bindings are non-standard. If you want them, you should -;;;have this function called by the inferior-lisp-load-hook: -;;; (add-hook 'inferior-lisp-load-hook 'inferior-lisp-install-letter-bindings) +;;;user, so these bindings are non-standard. If you want them: +;;; (with-eval-after-load 'inf-lisp 'inferior-lisp-install-letter-bindings) ;;;You can modify this function to install just the bindings you want." (defun inferior-lisp-install-letter-bindings () (define-key lisp-mode-map "\C-ce" 'lisp-eval-defun-and-go) @@ -632,6 +631,8 @@ See variable `lisp-describe-sym-command'." ;;;=============================== (defvar inferior-lisp-load-hook nil "This hook is run when the library `inf-lisp' is loaded.") +(make-obsolete-variable 'inferior-lisp-load-hook + "use `with-eval-after-load' instead." "28.1") (run-hooks 'inferior-lisp-load-hook) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index 5ec3e942753..5c50e2accdf 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -4570,7 +4570,7 @@ This function is intended for use in `after-change-functions'." ;; Comments (setq-local comment-start "// ") - (setq-local comment-start-skip "\\(//+\\|/\\*+\\)\\s *") + (setq-local comment-start-skip "\\(?://+\\|/\\*+\\)\\s *") (setq-local comment-end "") (setq-local fill-paragraph-function #'js-fill-paragraph) (setq-local normal-auto-fill-function #'js-do-auto-fill) @@ -4591,7 +4591,8 @@ This function is intended for use in `after-change-functions'." (setq imenu-create-index-function #'js--imenu-create-index) ;; for filling, pretend we're cc-mode - (c-init-language-vars js-mode) + (c-foreign-init-lit-pos-cache) + (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t) (setq-local comment-line-break-function #'c-indent-new-comment-line) (setq-local comment-multi-line t) (setq-local electric-indent-chars diff --git a/lisp/progmodes/meta-mode.el b/lisp/progmodes/meta-mode.el index 6f0e535def8..4a5d872b790 100644 --- a/lisp/progmodes/meta-mode.el +++ b/lisp/progmodes/meta-mode.el @@ -895,6 +895,8 @@ The environment marked is the one that contains point or follows point." "Hook evaluated when first loading Metafont or MetaPost mode." :type 'hook :group 'meta-font) +(make-obsolete-variable 'meta-mode-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom meta-common-mode-hook nil "Hook evaluated by both `metafont-mode' and `metapost-mode'." diff --git a/lisp/progmodes/octave.el b/lisp/progmodes/octave.el index 9e039562549..e07f818a68a 100644 --- a/lisp/progmodes/octave.el +++ b/lisp/progmodes/octave.el @@ -619,8 +619,7 @@ Key bindings: (add-hook 'before-save-hook 'octave-sync-function-file-names nil t) (setq-local beginning-of-defun-function 'octave-beginning-of-defun) (and octave-font-lock-texinfo-comment (octave-font-lock-texinfo-comment)) - (add-function :before-until (local 'eldoc-documentation-function) - 'octave-eldoc-function) + (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t) (easy-menu-add octave-mode-menu)) @@ -756,7 +755,7 @@ Key bindings: (setq font-lock-defaults '(inferior-octave-font-lock-keywords nil nil)) (setq-local info-lookup-mode 'octave-mode) - (setq-local eldoc-documentation-function 'octave-eldoc-function) + (add-hook 'eldoc-documentation-functions 'octave-eldoc-function nil t) (setq-local comint-input-ring-file-name (or (getenv "OCTAVE_HISTFILE") "~/.octave_hist")) @@ -1640,8 +1639,8 @@ code line." (nreverse result))))) (cdr octave-eldoc-cache)) -(defun octave-eldoc-function () - "A function for `eldoc-documentation-function' (which see)." +(defun octave-eldoc-function (&rest _ignored) + "A function for `eldoc-documentation-functions' (which see)." (when (inferior-octave-process-live-p) (let* ((ppss (syntax-ppss)) (paren-pos (cadr ppss)) diff --git a/lisp/progmodes/opascal.el b/lisp/progmodes/opascal.el index fcd9294f660..8c060991f42 100644 --- a/lisp/progmodes/opascal.el +++ b/lisp/progmodes/opascal.el @@ -1688,7 +1688,7 @@ comment block. If not in a // comment, just does a normal newline." ;; as comment starters. Fix it here by removing the "2" from the syntax ;; of the second char of such sequences. ("/\\(\\*\\)" (1 ". 3b")) - ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) + ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) ;; Pascal uses '' and "" rather than \' and \" to escape quotes. ("''\\|\"\"" (0 (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) diff --git a/lisp/progmodes/pascal.el b/lisp/progmodes/pascal.el index 13505d04a2d..fce059bafc7 100644 --- a/lisp/progmodes/pascal.el +++ b/lisp/progmodes/pascal.el @@ -187,7 +187,7 @@ ;; as comment starters. Fix it here by removing the "2" from the syntax ;; of the second char of such sequences. ("/\\(\\*\\)" (1 ". 3b")) - ("(\\(\\/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) + ("(\\(/\\)" (1 (prog1 ". 1c" (forward-char -1) nil))) ;; Pascal uses '' and "" rather than \' and \" to escape quotes. ("''\\|\"\"" (0 (if (save-excursion (nth 3 (syntax-ppss (match-beginning 0)))) @@ -589,7 +589,7 @@ See also `pascal-comment-area'." (interactive) (catch 'found (if (not (looking-at (concat "\\s \\|\\s)\\|" pascal-defun-re))) - (forward-sexp 1)) + (ignore-errors (forward-sexp 1))) (let ((nest 0) (max -1) (func 0) (reg (concat pascal-beg-block-re "\\|" pascal-end-block-re "\\|" @@ -1170,26 +1170,27 @@ indent of the current line in parameterlist." (defun pascal-type-completion (pascal-str) "Calculate all possible completions for types." - (let ((start (point)) - (pascal-all ()) - goon) - ;; Search for all reachable type declarations - (while (or (pascal-beg-of-defun) - (setq goon (not goon))) - (save-excursion - (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) - (point)) - (forward-char 1))) - (re-search-forward - "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" - start t) - (not (match-end 1))) - ;; Check current type declaration - (setq pascal-all - (nconc (pascal-get-completion-decl pascal-str) - pascal-all))))) + (save-excursion + (let ((start (point)) + (pascal-all ()) + goon) + ;; Search for all reachable type declarations + (while (or (pascal-beg-of-defun) + (setq goon (not goon))) + (save-excursion + (if (and (< start (prog1 (save-excursion (pascal-end-of-defun) + (point)) + (forward-char 1))) + (re-search-forward + "\\<type\\>\\|\\<\\(begin\\|function\\|procedure\\)\\>" + start t) + (not (match-end 1))) + ;; Check current type declaration + (setq pascal-all + (nconc (pascal-get-completion-decl pascal-str) + pascal-all))))) - pascal-all)) + pascal-all))) (defun pascal-var-completion (prefix) "Calculate all possible completions for variables (or constants)." @@ -1263,11 +1264,13 @@ indent of the current line in parameterlist." (and (eq state 'defun) (save-excursion (re-search-backward ")[ \t]*:" (point-at-bol) t)))) - (if (or (eq state 'paramlist) (eq state 'defun)) - (pascal-beg-of-defun)) - (nconc - (pascal-type-completion pascal-str) - (pascal-keyword-completion pascal-type-keywords pascal-str))) + (save-excursion + (if (or (eq state 'paramlist) (eq state 'defun)) + (pascal-beg-of-defun)) + (nconc + (pascal-type-completion pascal-str) + (pascal-keyword-completion pascal-type-keywords + pascal-str)))) ( ;--Starting a new statement (and (not (eq state 'contexp)) (save-excursion @@ -1392,7 +1395,7 @@ The default is a name found in the buffer around point." (defvar pascal-outline-map (let ((map (make-sparse-keymap))) (if (fboundp 'set-keymap-name) - (set-keymap-name pascal-outline-map 'pascal-outline-map)) + (set-keymap-name map 'pascal-outline-map)) (define-key map "\M-\C-a" 'pascal-outline-prev-defun) (define-key map "\M-\C-e" 'pascal-outline-next-defun) (define-key map "\C-c\C-d" 'pascal-outline-goto-defun) diff --git a/lisp/progmodes/perl-mode.el b/lisp/progmodes/perl-mode.el index f864f6a34cd..ff0b6a331bc 100644 --- a/lisp/progmodes/perl-mode.el +++ b/lisp/progmodes/perl-mode.el @@ -235,7 +235,7 @@ (match-beginning 0)))))) (string-to-syntax ". p")))) ;; Handle funny names like $DB'stop. - ("\\$ ?{?^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_")) + ("\\$ ?{?\\^?[_[:alpha:]][_[:alnum:]]*\\('\\)[_[:alpha:]]" (1 "_")) ;; format statements ("^[ \t]*format.*=[ \t]*\\(\n\\)" (1 (prog1 "\"" (perl-syntax-propertize-special-constructs end)))) diff --git a/lisp/progmodes/project.el b/lisp/progmodes/project.el index f5f4092babf..51b9347bb93 100644 --- a/lisp/progmodes/project.el +++ b/lisp/progmodes/project.el @@ -1,6 +1,11 @@ ;;; project.el --- Operations on the current project -*- lexical-binding: t; -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. +;; Version: 0.5.0 +;; Package-Requires: ((emacs "26.3")) + +;; This is a GNU ELPA :core package. Avoid using functionality that +;; not compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -19,6 +24,11 @@ ;;; Commentary: +;; NOTE: The project API is still experimental and can change in major, +;; backward-incompatible ways. Everyone is encouraged to try it, and +;; report to us any problems or use cases we hadn't anticipated, by +;; sending an email to emacs-devel, or `M-x report-emacs-bug'. +;; ;; This file contains generic infrastructure for dealing with ;; projects, some utility functions, and commands using that ;; infrastructure. @@ -27,16 +37,29 @@ ;; current project, without having to know which package handles ;; detection of that project type, parsing its config files, etc. ;; -;; NOTE: The project API is still experimental and can change in major, -;; backward-incompatible ways. Everyone is encouraged to try it, and -;; report to us any problems or use cases we hadn't anticipated, by -;; sending an email to emacs-devel, or `M-x report-emacs-bug'. +;; This file consists of following parts: +;; +;; Infrastructure (the public API): +;; +;; Function `project-current' that returns the current project +;; instance based on the value of the hook `project-find-functions', +;; and several generic functions that act on it. ;; -;; Infrastructure: +;; `project-root' must be defined for every project. +;; `project-files' can be overridden for performance purposes. +;; `project-ignores' and `project-external-roots' describe the project +;; files and its relations to external directories. `project-files' +;; should be consistent with `project-ignores'. ;; -;; Function `project-current', to determine the current project -;; instance, and 5 (at the moment) generic functions that act on it. -;; This list is to be extended in future versions. +;; This list can change in future versions. +;; +;; VC project: +;; +;; Originally conceived as an example implementation, now it's a +;; relatively fast backend that delegates to 'git ls-files' or 'hg +;; status' to list the project's files. It honors the VC ignore +;; files, but supports additions to the list using the user option +;; `project-vc-ignores' (usually through .dir-locals.el). ;; ;; Utils: ;; @@ -45,9 +68,49 @@ ;; ;; Commands: ;; -;; `project-find-file', `project-find-regexp' and -;; `project-or-external-find-regexp' use the current API, and thus -;; will work in any project that has an adapter. +;; `project-prefix-map' contains the full list of commands defined in +;; this package. This map uses the prefix `C-x p' by default. +;; Type `C-x p f' to find file in the current project. +;; Type `C-x p C-h' to see all available commands and bindings. +;; +;; All commands defined in this package are implemented using the +;; public API only. As a result, they will work with any project +;; backend that follows the protocol. +;; +;; Any third-party code that wants to use this package should likewise +;; target the public API. Use any of the built-in commands as the +;; example. +;; +;; How to create a new backend: +;; +;; - Consider whether you really should, or whether there are other +;; ways to reach your goals. If the backend's performance is +;; significantly lower than that of the built-in one, and it's first +;; in the list, it will affect all commands that use it. Unless you +;; are going to be using it only yourself or in special circumstances, +;; you will probably want it to be fast, and it's unlikely to be a +;; trivial endeavor. `project-files' is the method to optimize (the +;; default implementation gets slower the more files the directory +;; has, and the longer the list of ignores is). +;; +;; - Choose the format of the value that represents a project for your +;; backend (we call it project instance). Don't use any of the +;; formats from other backends. The format can be arbitrary, as long +;; as the datatype is something `cl-defmethod' can dispatch on. The +;; value should be stable (when compared with `equal') across +;; invocations, meaning calls to that function from buffers belonging +;; to the same project should return equal values. +;; +;; - Write a new function that will determine the current project +;; based on the directory and add it to `project-find-functions' +;; (which see) using `add-hook'. It is a good idea to depend on the +;; directory only, and not on the current major mode, for example. +;; Because the usual expectation is that all files in the directory +;; belong to the same project (even if some/most of them are ignored). +;; +;; - Define new methods for some or all generic functions for this +;; backend using `cl-defmethod'. A `project-root' method is +;; mandatory, `project-files' is recommended, the rest are optional. ;;; TODO: @@ -72,9 +135,7 @@ ;; whole Emacs session, independent of the current directory. Or, ;; in the more advanced case, open a set of projects, and have some ;; project-related commands to use them all. E.g., have a command -;; to search for a regexp across all open projects. Provide a -;; history of projects that were opened in the past (storing it as a -;; list of directories should suffice). +;; to search for a regexp across all open projects. ;; ;; * Support for project-local variables: a UI to edit them, and a ;; utility function to retrieve a value. Probably useless without @@ -88,43 +149,81 @@ ;;; Code: (require 'cl-generic) +(require 'seq) +(eval-when-compile (require 'subr-x)) + +(defgroup project nil + "Operations on the current project." + :version "28.1" + :group 'tools) (defvar project-find-functions (list #'project-try-vc) "Special hook to find the project containing a given directory. Each functions on this hook is called in turn with one -argument (the directory) and should return either nil to mean -that it is not applicable, or a project instance.") +argument, the directory in which to look, and should return +either nil to mean that it is not applicable, or a project instance. +The exact form of the project instance is up to each respective +function; the only practical limitation is to use values that +`cl-defmethod' can dispatch on, like a cons cell, or a list, or a +CL struct.") + +(defvar project-current-inhibit-prompt nil + "Non-nil to skip prompting the user in `project-current'.") ;;;###autoload -(defun project-current (&optional maybe-prompt dir) - "Return the project instance in DIR or `default-directory'. -When no project found in DIR, and MAYBE-PROMPT is non-nil, ask -the user for a different directory to look in. If that directory -is not a part of a detectable project either, return a -`transient' project instance rooted in it." - (unless dir (setq dir default-directory)) - (let ((pr (project--find-in-directory dir))) +(defun project-current (&optional maybe-prompt directory) + "Return the project instance in DIRECTORY, defaulting to `default-directory'. + +When no project is found in that directory, the result depends on +the value of MAYBE-PROMPT: if it is nil or omitted, return nil, +else ask the user for a directory in which to look for the +project, and if no project is found there, return a \"transient\" +project instance. + +The \"transient\" project instance is a special kind of value +which denotes a project rooted in that directory and includes all +the files under the directory except for those that should be +ignored (per `project-ignores'). + +See the doc string of `project-find-functions' for the general form +of the project instance object." + (unless directory (setq directory default-directory)) + (let ((pr (project--find-in-directory directory))) (cond (pr) - (maybe-prompt - (setq dir (read-directory-name "Choose the project directory: " dir nil t) - pr (project--find-in-directory dir)) - (unless pr - (message "Using `%s' as a transient project root" dir) - (setq pr (cons 'transient dir))))) + ((unless project-current-inhibit-prompt + maybe-prompt) + (setq directory (project-prompt-project-dir) + pr (project--find-in-directory directory)))) + (when maybe-prompt + (if pr + (project-remember-project pr) + (project--remove-from-project-list directory) + (setq pr (cons 'transient directory)))) pr)) (defun project--find-in-directory (dir) (run-hook-with-args-until-success 'project-find-functions dir)) -(cl-defgeneric project-roots (project) - "Return the list of directory roots of the current project. +(cl-defgeneric project-root (project) + "Return root directory of the current project. -Most often it's just one directory which contains the project -build file and everything else in the project. But in more -advanced configurations, a project can span multiple directories. +It usually contains the main build file, dependencies +configuration file, etc. Though neither is mandatory. -The directory names should be absolute.") +The directory name must be absolute." + (car (project-roots project))) + +(cl-defgeneric project-roots (project) + "Return the list containing the current project root. + +The function is obsolete, all projects have one main root anyway, +and the rest should be possible to express through +`project-external-roots'." + ;; FIXME: Can we specify project's version here? + ;; FIXME: Could we make this affect cl-defmethod calls too? + (declare (obsolete project-root "0.3.0")) + (list (project-root project))) ;; FIXME: Add MODE argument, like in `ede-source-paths'? (cl-defgeneric project-external-roots (_project) @@ -133,18 +232,14 @@ The directory names should be absolute.") It's the list of directories outside of the project that are still related to it. If the project deals with source code then, depending on the languages used, this list should include the -headers search path, load path, class path, and so on. - -The rule of thumb for whether to include a directory here, and -not in `project-roots', is whether its contents are meant to be -edited together with the rest of the project." +headers search path, load path, class path, and so on." nil) (cl-defgeneric project-ignores (_project _dir) "Return the list of glob patterns to ignore inside DIR. Patterns can match both regular files and directories. To root an entry, start it with `./'. To match directories only, -end it with `/'. DIR must be one of `project-roots' or +end it with `/'. DIR must be either `project-root' or one of `project-external-roots'." ;; TODO: Document and support regexp ignores as used by Hg. ;; TODO: Support whitelist entries. @@ -165,21 +260,22 @@ end it with `/'. DIR must be one of `project-roots' or (t (complete-with-action action all-files string pred))))) -(cl-defmethod project-roots ((project (head transient))) - (list (cdr project))) +(cl-defmethod project-root ((project (head transient))) + (cdr project)) (cl-defgeneric project-files (project &optional dirs) "Return a list of files in directories DIRS in PROJECT. DIRS is a list of absolute directories; it should be some -subset of the project roots and external roots. +subset of the project root and external roots. The default implementation uses `find-program'. PROJECT is used to find the list of ignores for each directory." - (cl-mapcan + (mapcan (lambda (dir) (project--files-in-directory dir (project--dir-ignores project dir))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (defun project--files-in-directory (dir ignores &optional files) (require 'find-dired) @@ -218,14 +314,24 @@ to find the list of ignores for each directory." local-files)))) (defgroup project-vc nil - "Project implementation using the VC package." + "Project implementation based on the VC package." :version "25.1" - :group 'tools) + :group 'project) (defcustom project-vc-ignores nil "List of patterns to include in `project-ignores'." :type '(repeat string) - :safe 'listp) + :safe #'listp) + +(defcustom project-vc-merge-submodules t + "Non-nil to consider submodules part of the parent project. + +After changing this variable (using Customize or .dir-locals.el) +you might have to restart Emacs to see the effect." + :type 'boolean + :version "28.1" + :package-version '(project . "0.2.0") + :safe #'booleanp) ;; FIXME: Using the current approach, major modes are supposed to set ;; this variable to a buffer-local value. So we don't have access to @@ -263,20 +369,56 @@ The directory names should be absolute. Used in the VC project backend implementation of `project-external-roots'.") (defun project-try-vc (dir) - (let* ((backend (ignore-errors (vc-responsible-backend dir))) + (let* ((backend + ;; FIXME: This is slow. Cache it. + (ignore-errors (vc-responsible-backend dir))) (root (pcase backend ('Git ;; Don't stop at submodule boundary. + ;; FIXME: Cache for a shorter time. (or (vc-file-getprop dir 'project-git-root) - (vc-file-setprop dir 'project-git-root - (vc-find-root dir ".git/")))) + (let ((root (vc-call-backend backend 'root dir))) + (vc-file-setprop + dir 'project-git-root + (if (and + ;; FIXME: Invalidate the cache when the value + ;; of this variable changes. + (project--vc-merge-submodules-p root) + (project--submodule-p root)) + (let* ((parent (file-name-directory + (directory-file-name root)))) + (vc-call-backend backend 'root parent)) + root))))) ('nil nil) (_ (ignore-errors (vc-call-backend backend 'root dir)))))) (and root (cons 'vc root)))) -(cl-defmethod project-roots ((project (head vc))) - (list (cdr project))) +(defun project--submodule-p (root) + ;; XXX: We only support Git submodules for now. + ;; + ;; For submodules, at least, we expect the users to prefer them to + ;; be considered part of the parent project. For those who don't, + ;; there is the custom var now. + ;; + ;; Some users may also set up things equivalent to Git submodules + ;; using "git worktree" (for example). However, we expect that most + ;; of them would prefer to treat those as separate projects anyway. + (let* ((gitfile (expand-file-name ".git" root))) + (cond + ((file-directory-p gitfile) + nil) + ((with-temp-buffer + (insert-file-contents gitfile) + (goto-char (point-min)) + ;; Kind of a hack to distinguish a submodule from + ;; other cases of .git files pointing elsewhere. + (looking-at "gitdir: [./]+/\\.git/modules/")) + t) + (t nil)))) + +(cl-defmethod project-root ((project (head vc))) + (cdr project)) (cl-defmethod project-external-roots ((project (head vc))) (project-subtract-directories @@ -284,10 +426,10 @@ backend implementation of `project-external-roots'.") (mapcar #'file-name-as-directory (funcall project-vc-external-roots-function))) - (project-roots project))) + (list (project-root project)))) (cl-defmethod project-files ((project (head vc)) &optional dirs) - (cl-mapcan + (mapcan (lambda (dir) (let (backend) (if (and (file-equal-p dir (cdr project)) @@ -302,7 +444,8 @@ backend implementation of `project-external-roots'.") (project--files-in-directory dir (project--dir-ignores project dir))))) - (or dirs (project-roots project)))) + (or dirs + (list (project-root project))))) (declare-function vc-git--program-version "vc-git") (declare-function vc-git--run-command-string "vc-git") @@ -331,20 +474,23 @@ backend implementation of `project-external-roots'.") (split-string (apply #'vc-git--run-command-string nil "ls-files" args) "\0" t))) - ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. - (let* ((submodules (project--git-submodules)) - (sub-files - (mapcar - (lambda (module) - (when (file-directory-p module) - (project--vc-list-files - (concat default-directory module) - backend - extra-ignores))) - submodules))) - (setq files - (apply #'nconc files sub-files))) - files)) + (when (project--vc-merge-submodules-p default-directory) + ;; Unfortunately, 'ls-files --recurse-submodules' conflicts with '-o'. + (let* ((submodules (project--git-submodules)) + (sub-files + (mapcar + (lambda (module) + (when (file-directory-p module) + (project--vc-list-files + (concat default-directory module) + backend + extra-ignores))) + submodules))) + (setq files + (apply #'nconc files sub-files)))) + ;; 'git ls-files' returns duplicate entries for merge conflicts. + ;; XXX: Better solutions welcome, but this seems cheap enough. + (delete-consecutive-dups files))) (`Hg (let ((default-directory (expand-file-name (file-name-as-directory dir))) args) @@ -362,6 +508,11 @@ backend implementation of `project-external-roots'.") (lambda (s) (concat default-directory s)) (split-string (buffer-string) "\0" t))))))) +(defun project--vc-merge-submodules-p (dir) + (project--value-in-dir + 'project-vc-merge-submodules + dir)) + (defun project--git-submodules () ;; 'git submodule foreach' is much slower. (condition-case nil @@ -376,7 +527,7 @@ backend implementation of `project-external-roots'.") (cl-defmethod project-ignores ((project (head vc)) dir) (let* ((root (cdr project)) - backend) + backend) (append (when (file-equal-p dir root) (setq backend (vc-responsible-backend root)) @@ -424,6 +575,98 @@ DIRS must contain directory names." (hack-dir-local-variables-non-file-buffer)) (symbol-value var))) + +;;; Project commands + +;;;###autoload +(defvar project-prefix-map + (let ((map (make-sparse-keymap))) + (define-key map "f" 'project-find-file) + (define-key map "F" 'project-or-external-find-file) + (define-key map "b" 'project-switch-to-buffer) + (define-key map "s" 'project-shell) + (define-key map "d" 'project-dired) + (define-key map "v" 'project-vc-dir) + (define-key map "c" 'project-compile) + (define-key map "e" 'project-eshell) + (define-key map "k" 'project-kill-buffers) + (define-key map "p" 'project-switch-project) + (define-key map "g" 'project-find-regexp) + (define-key map "G" 'project-or-external-find-regexp) + (define-key map "r" 'project-query-replace-regexp) + map) + "Keymap for project commands.") + +;;;###autoload (define-key ctl-x-map "p" project-prefix-map) + +;; We can't have these place-specific maps inherit from +;; project-prefix-map because project--other-place-command needs to +;; know which map the key binding came from, as if it came from one of +;; these maps, we don't want to set display-buffer-overriding-action + +(defvar project-other-window-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-o" #'project-display-buffer) + map) + "Keymap for project commands that display buffers in other windows.") + +(defvar project-other-frame-map + (let ((map (make-sparse-keymap))) + (define-key map "\C-o" #'project-display-buffer-other-frame) + map) + "Keymap for project commands that display buffers in other frames.") + +(defun project--other-place-command (action &optional map) + (let* ((key (read-key-sequence-vector nil t)) + (place-cmd (lookup-key map key)) + (generic-cmd (lookup-key project-prefix-map key)) + (switch-to-buffer-obey-display-actions t) + (display-buffer-overriding-action (unless place-cmd action))) + (if-let ((cmd (or place-cmd generic-cmd))) + (call-interactively cmd) + (user-error "%s is undefined" (key-description key))))) + +;;;###autoload +(defun project-other-window-command () + "Run project command, displaying resultant buffer in another window. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-window-map}" + (interactive) + (project--other-place-command '((display-buffer-pop-up-window) + (inhibit-same-window . t)) + project-other-window-map)) + +;;;###autoload (define-key ctl-x-4-map "p" #'project-other-window-command) + +;;;###autoload +(defun project-other-frame-command () + "Run project command, displaying resultant buffer in another frame. + +The following commands are available: + +\\{project-prefix-map} +\\{project-other-frame-map}" + (interactive) + (project--other-place-command '((display-buffer-pop-up-frame)) + project-other-frame-map)) + +;;;###autoload (define-key ctl-x-5-map "p" #'project-other-frame-command) + +;;;###autoload +(defun project-other-tab-command () + "Run project command, displaying resultant buffer in a new tab. + +The following commands are available: + +\\{project-prefix-map}" + (interactive) + (project--other-place-command '((display-buffer-in-new-tab)))) + +;;;###autoload (define-key tab-prefix-map "p" #'project-other-tab-command) + (declare-function grep-read-files "grep") (declare-function xref--show-xrefs "xref") (declare-function xref--find-ignores-arguments "xref") @@ -443,7 +686,7 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." (let* ((pr (project-current t)) (files (if (not current-prefix-arg) - (project-files pr (project-roots pr)) + (project-files pr) (let ((dir (read-directory-name "Base directory: " nil default-directory t))) (project--files-in-directory dir @@ -454,9 +697,8 @@ requires quoting, e.g. `\\[quoted-insert]<space>'." nil))) (defun project--dir-ignores (project dir) - (let* ((roots (project-roots project)) - (root (cl-find dir roots :test #'file-in-directory-p))) - (if (not root) + (let ((root (project-root project))) + (if (not (file-in-directory-p dir root)) (project-ignores nil nil) ;The defaults. (let ((ignores (project-ignores project root))) (if (file-equal-p root dir) @@ -474,8 +716,8 @@ pattern to search for." (require 'xref) (let* ((pr (project-current t)) (files - (project-files pr (append - (project-roots pr) + (project-files pr (cons + (project-root pr) (project-external-roots pr))))) (xref--show-xrefs (apply-partially #'project--find-regexp-in-files regexp files) @@ -513,23 +755,23 @@ pattern to search for." ;;;###autoload (defun project-find-file () - "Visit a file (with completion) in the current project's roots. + "Visit a file (with completion) in the current project. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (project-roots pr))) + (dirs (list (project-root pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) ;;;###autoload (defun project-or-external-find-file () - "Visit a file (with completion) in the current project's roots or external roots. + "Visit a file (with completion) in the current project or external roots. The completion default is the filename at point, if one is recognized." (interactive) (let* ((pr (project-current t)) - (dirs (append - (project-roots pr) + (dirs (cons + (project-root pr) (project-external-roots pr)))) (project-find-file-in (thing-at-point 'filename) dirs pr))) @@ -541,6 +783,7 @@ For the arguments list, see `project--read-file-cpd-relative'." (const :tag "Read with completion from absolute names" project--read-file-absolute) (function :tag "Custom function" nil)) + :group 'project :version "27.1") (defun project--read-file-cpd-relative (prompt @@ -577,9 +820,10 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in (defun project-find-file-in (filename dirs project) "Complete FILENAME in DIRS in PROJECT and visit the result." (let* ((all-files (project-files project dirs)) + (completion-ignore-case read-file-name-completion-ignore-case) (file (funcall project-read-file-name-function - "Find file" all-files nil nil - filename))) + "Find file" all-files nil nil + filename))) (if (string= file "") (user-error "You didn't specify the file") (find-file file)))) @@ -605,6 +849,57 @@ PREDICATE, HIST, and DEFAULT have the same meaning as in collection predicate t res hist nil))) res)) +;;;###autoload +(defun project-dired () + "Start Dired in the current project's root." + (interactive) + (dired (project-root (project-current t)))) + +;;;###autoload +(defun project-vc-dir () + "Run VC-Dir in the current project's root." + (interactive) + (vc-dir (project-root (project-current t)))) + +;;;###autoload +(defun project-shell () + "Start an inferior shell in the current project's root directory. +If a buffer already exists for running a shell in the project's root, +switch to it. Otherwise, create a new shell buffer. +With \\[universal-argument] prefix arg, create a new inferior shell buffer even +if one already exists." + (interactive) + (let* ((default-directory (project-root (project-current t))) + (default-project-shell-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-shell*")) + (shell-buffer (get-buffer default-project-shell-name))) + (if (and shell-buffer (not current-prefix-arg)) + (pop-to-buffer shell-buffer) + (shell (generate-new-buffer-name default-project-shell-name))))) + +;;;###autoload +(defun project-eshell () + "Start Eshell in the current project's root directory. +If a buffer already exists for running Eshell in the project's root, +switch to it. Otherwise, create a new Eshell buffer. +With \\[universal-argument] prefix arg, create a new Eshell buffer even +if one already exists." + (interactive) + (defvar eshell-buffer-name) + (let* ((default-directory (project-root (project-current t))) + (eshell-buffer-name + (concat "*" (file-name-nondirectory + (directory-file-name + (file-name-directory default-directory))) + "-eshell*")) + (eshell-buffer (get-buffer eshell-buffer-name))) + (if (and eshell-buffer (not current-prefix-arg)) + (pop-to-buffer eshell-buffer) + (eshell t)))) + (declare-function fileloop-continue "fileloop" ()) ;;;###autoload @@ -632,5 +927,325 @@ loop using the command \\[fileloop-continue]." from to (project-files (project-current t)) 'default) (fileloop-continue)) +(defvar compilation-read-command) +(declare-function compilation-read-command "compile") + +;;;###autoload +(defun project-compile (command &optional comint) + "Run `compile' in the project root. +Arguments the same as in `compile'." + (interactive + (list + (let ((command (eval compile-command))) + (if (or compilation-read-command current-prefix-arg) + (compilation-read-command command) + command)) + (consp current-prefix-arg))) + (let* ((pr (project-current t)) + (default-directory (project-root pr))) + (compile command comint))) + +(defun project--read-project-buffer () + (let* ((pr (project-current t)) + (current-buffer (current-buffer)) + (other-buffer (other-buffer current-buffer)) + (other-name (buffer-name other-buffer)) + (predicate + (lambda (buffer) + ;; BUFFER is an entry (BUF-NAME . BUF-OBJ) of Vbuffer_alist. + (and (cdr buffer) + (equal pr + (with-current-buffer (cdr buffer) + (project-current))))))) + (read-buffer + "Switch to buffer: " + (when (funcall predicate (cons other-name other-buffer)) + other-name) + nil + predicate))) + +;;;###autoload +(defun project-switch-to-buffer (buffer-or-name) + "Display buffer BUFFER-OR-NAME in the selected window. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical." + (interactive (list (project--read-project-buffer))) + (switch-to-buffer buffer-or-name)) + +;;;###autoload +(defun project-display-buffer (buffer-or-name) + "Display BUFFER-OR-NAME in some window, without selecting it. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer' as a subroutine, which see +for how it is determined where the buffer will be displayed." + (interactive (list (project--read-project-buffer))) + (display-buffer buffer-or-name)) + +;;;###autoload +(defun project-display-buffer-other-frame (buffer-or-name) + "Display BUFFER-OR-NAME preferably in another frame. +When called interactively, prompts for a buffer belonging to the +current project. Two buffers belong to the same project if their +project instances, as reported by `project-current' in each +buffer, are identical. + +This function uses `display-buffer-other-frame' as a subroutine, +which see for how it is determined where the buffer will be +displayed." + (interactive (list (project--read-project-buffer))) + (display-buffer-other-frame buffer-or-name)) + +(defcustom project-kill-buffer-conditions + '(buffer-file-name ; All file-visiting buffers are included. + ;; Most of the temp buffers in the background: + (major-mode . fundamental-mode) + ;; non-text buffer such as xref, occur, vc, log, ... + (and (derived-mode . special-mode) + (not (major-mode . help-mode))) + (derived-mode . compilation-mode) + (derived-mode . dired-mode) + (derived-mode . diff-mode)) + "List of conditions to kill buffers related to a project. +This list is used by `project-kill-buffers'. +Each condition is either: +- a regular expression, to match a buffer name, +- a predicate function that takes a buffer object as argument + and returns non-nil if the buffer should be killed, +- a cons-cell, where the car describes how to interpret the cdr. + The car can be one of the following: + * `major-mode': the buffer is killed if the buffer's major + mode is eq to the cons-cell's cdr + * `defived-mode': the buffer is killed if the buffer's major + mode is derived from the major mode denoted by the cons-cell's + cdr + * `not': the cdr is interpreted as a negation of a condition. + * `and': the cdr is a list of recursive conditions, that all have + to be met. + * `or': the cdr is a list of recursive conditions, of which at + least one has to be met. + +If any of these conditions are satified for a buffer in the +current project, it will be killed." + :type '(repeat (choice regexp function symbol + (cons :tag "Major mode" + (const major-mode) symbol) + (cons :tag "Derived mode" + (const derived-mode) symbol) + (cons :tag "Negation" + (const not) sexp) + (cons :tag "Conjunction" + (const and) sexp) + (cons :tag "Disjunction" + (const or) sexp))) + :version "28.1" + :group 'project + :package-version '(project . "0.6.0")) + +(defun project--buffer-list (pr) + "Return the list of all buffers in project PR." + (let (bufs) + (dolist (buf (buffer-list)) + (when (equal pr + (with-current-buffer buf + (project-current))) + (push buf bufs))) + (nreverse bufs))) + +(defun project--kill-buffer-check (buf conditions) + "Check if buffer BUF matches any element of the list CONDITIONS. +See `project-kill-buffer-conditions' for more details on the form +of CONDITIONS." + (catch 'kill + (dolist (c conditions) + (when (cond + ((stringp c) + (string-match-p c (buffer-name buf))) + ((symbolp c) + (funcall c buf)) + ((eq (car-safe c) 'major-mode) + (eq (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'derived-mode) + (provided-mode-derived-p + (buffer-local-value 'major-mode buf) + (cdr c))) + ((eq (car-safe c) 'not) + (not (project--kill-buffer-check buf (cdr c)))) + ((eq (car-safe c) 'or) + (project--kill-buffer-check buf (cdr c))) + ((eq (car-safe c) 'and) + (seq-every-p + (apply-partially #'project--kill-buffer-check + buf) + (mapcar #'list (cdr c))))) + (throw 'kill t))))) + +(defun project--buffers-to-kill (pr) + "Return list of buffers in project PR to kill. +What buffers should or should not be killed is described +in `project-kill-buffer-conditions'." + (let (bufs) + (dolist (buf (project--buffer-list pr)) + (when (project--kill-buffer-check buf project-kill-buffer-conditions) + (push buf bufs))) + bufs)) + +;;;###autoload +(defun project-kill-buffers (&optional no-confirm) + "Kill the buffers belonging to the current project. +Two buffers belong to the same project if their project +instances, as reported by `project-current' in each buffer, are +identical. Only the buffers that match a condition in +`project-kill-buffer-conditions' will be killed. If NO-CONFIRM +is non-nil, the command will not ask the user for confirmation. +NO-CONFIRM is always nil when the command is invoked +interactivly." + (interactive) + (let* ((pr (project-current t)) + (bufs (project--buffers-to-kill pr))) + (cond (no-confirm + (mapc #'kill-buffer bufs)) + ((null bufs) + (message "No buffers to kill")) + ((yes-or-no-p (format "Kill %d buffers in %s? " + (length bufs) + (project-root pr))) + (mapc #'kill-buffer bufs))))) + + +;;; Project list + +(defcustom project-list-file (locate-user-emacs-file "projects") + "File in which to save the list of known projects." + :type 'file + :version "28.1" + :group 'project) + +(defvar project--list 'unset + "List structure containing root directories of known projects. +With some possible metadata (to be decided).") + +(defun project--read-project-list () + "Initialize `project--list' using contents of `project-list-file'." + (let ((filename project-list-file)) + (setq project--list + (when (file-exists-p filename) + (with-temp-buffer + (insert-file-contents filename) + (read (current-buffer))))) + (unless (seq-every-p + (lambda (elt) (stringp (car-safe elt))) + project--list) + (warn "Contents of %s are in wrong format, resetting" + project-list-file) + (setq project--list nil)))) + +(defun project--ensure-read-project-list () + "Initialize `project--list' if it isn't already initialized." + (when (eq project--list 'unset) + (project--read-project-list))) + +(defun project--write-project-list () + "Save `project--list' in `project-list-file'." + (let ((filename project-list-file)) + (with-temp-buffer + (insert ";;; -*- lisp-data -*-\n") + (pp project--list (current-buffer)) + (write-region nil nil filename nil 'silent)))) + +;;;###autoload +(defun project-remember-project (pr) + "Add project PR to the front of the project list. +Save the result in `project-list-file' if the list of projects has changed." + (project--ensure-read-project-list) + (let ((dir (project-root pr))) + (unless (equal (caar project--list) dir) + (setq project--list (assoc-delete-all dir project--list)) + (push (list dir) project--list) + (project--write-project-list)))) + +(defun project--remove-from-project-list (pr-dir) + "Remove directory PR-DIR of a missing project from the project list. +If the directory was in the list before the removal, save the +result in `project-list-file'. Announce the project's removal +from the list." + (project--ensure-read-project-list) + (when (assoc pr-dir project--list) + (setq project--list (assoc-delete-all pr-dir project--list)) + (message "Project `%s' not found; removed from list" pr-dir) + (project--write-project-list))) + +(defun project-prompt-project-dir () + "Prompt the user for a directory that is one of the known project roots. +The project is chosen among projects known from the project list, +see `project-list-file'. +It's also possible to enter an arbitrary directory not in the list." + (project--ensure-read-project-list) + (let* ((dir-choice "... (choose a dir)") + (choices + ;; XXX: Just using this for the category (for the substring + ;; completion style). + (project--file-completion-table + (append project--list `(,dir-choice)))) + (pr-dir (completing-read "Select project: " choices nil t))) + (if (equal pr-dir dir-choice) + (read-directory-name "Select directory: " default-directory nil t) + pr-dir))) + +;;;###autoload +(defun project-known-project-roots () + "Return the list of root directories of all known projects." + (project--ensure-read-project-list) + (mapcar #'car project--list)) + + +;;; Project switching + +;;;###autoload +(defvar project-switch-commands + '((?f "Find file" project-find-file) + (?g "Find regexp" project-find-regexp) + (?d "Dired" project-dired) + (?v "VC-Dir" project-vc-dir) + (?e "Eshell" project-eshell)) + "Alist mapping keys to project switching menu entries. +Used by `project-switch-project' to construct a dispatch menu of +commands available upon \"switching\" to another project. + +Each element is of the form (KEY LABEL COMMAND), where COMMAND is the +command to run when KEY is pressed. LABEL is used to distinguish +the menu entries in the dispatch menu.") + +(defun project--keymap-prompt () + "Return a prompt for the project swithing dispatch menu." + (mapconcat + (pcase-lambda (`(,key ,label)) + (format "[%s] %s" + (propertize (key-description `(,key)) 'face 'bold) + label)) + project-switch-commands + " ")) + +;;;###autoload +(defun project-switch-project () + "\"Switch\" to another project by running an Emacs command. +The available commands are presented as a dispatch menu +made from `project-switch-commands'." + (interactive) + (let ((dir (project-prompt-project-dir)) + (choice nil)) + (while (not choice) + (setq choice (assq (read-event (project--keymap-prompt)) + project-switch-commands))) + (let ((default-directory dir) + (project-current-inhibit-prompt t)) + (call-interactively (nth 2 choice))))) + (provide 'project) ;;; project.el ends here diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 785b941402a..3af55be4a19 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -261,7 +261,6 @@ (require 'ansi-color) (require 'cl-lib) (require 'comint) -(require 'json) (require 'tramp-sh) ;; Avoid compiler warnings @@ -634,6 +633,8 @@ builtins.") (,(lambda (limit) (let ((re (python-rx (group (+ (any word ?. ?_))) (? ?\[ (+ (not (any ?\]))) ?\]) (* space) + ;; A type, like " : int ". + (? ?: (* space) (+ (any word ?. ?_)) (* space)) assignment-operator)) (res nil)) (while (and (setq res (re-search-forward re limit t)) @@ -1993,7 +1994,7 @@ position, else returns nil." ;; IPython prompts activated, this adds some safeguard for that. "In : " "\\.\\.\\.: ") "List of regular expressions matching input prompts." - :type '(repeat string) + :type '(repeat regexp) :version "24.4") (defcustom python-shell-prompt-output-regexps @@ -2001,28 +2002,28 @@ position, else returns nil." "Out\\[[0-9]+\\]: " ; IPython "Out :") ; ipdb safeguard "List of regular expressions matching output prompts." - :type '(repeat string) + :type '(repeat regexp) :version "24.4") (defcustom python-shell-prompt-regexp ">>> " "Regular expression matching top level input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-block-regexp "\\.\\.\\.:? " "Regular expression matching block input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-output-regexp "" "Regular expression matching output prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (defcustom python-shell-prompt-pdb-regexp "[(<]*[Ii]?[Pp]db[>)]+ " "Regular expression matching pdb input prompt of Python shell. It should not contain a caret (^) at the beginning." - :type 'string) + :type 'regexp) (define-obsolete-variable-alias 'python-shell-enable-font-lock 'python-shell-font-lock-enable "25.1") @@ -2091,7 +2092,7 @@ executed through tramp connections." This variable, when set to a string, makes the environment to be modified such that shells are started within the specified virtualenv." - :type '(choice (const nil) string) + :type '(choice (const nil) directory) :group 'python) (defcustom python-shell-setup-codes nil @@ -2111,7 +2112,7 @@ virtualenv." "(" (group (1+ digit)) ")" (1+ (not (any "("))) "()") 1 2)) "`compilation-error-regexp-alist' for inferior Python." - :type '(alist string) + :type '(alist regexp) :group 'python) (defmacro python-shell--add-to-path-with-priority (pathvar paths) @@ -2276,6 +2277,18 @@ Do not set this variable directly, instead use Do not set this variable directly, instead use `python-shell-prompt-set-calculated-regexps'.") +(defalias 'python--parse-json-array + (if (fboundp 'json-parse-string) + (lambda (string) + (json-parse-string string :array-type 'list)) + (require 'json) + (defvar json-array-type) + (declare-function json-read-from-string "json" (string)) + (lambda (string) + (let ((json-array-type 'list)) + (json-read-from-string string)))) + "Parse the JSON array in STRING into a Lisp list.") + (defun python-shell-prompt-detect () "Detect prompts for the current `python-shell-interpreter'. When prompts can be retrieved successfully from the @@ -2324,11 +2337,11 @@ detection and just returns nil." (catch 'prompts (dolist (line (split-string output "\n" t)) (let ((res - ;; Check if current line is a valid JSON array - (and (string= (substring line 0 2) "[\"") + ;; Check if current line is a valid JSON array. + (and (string-prefix-p "[\"" line) (ignore-errors - ;; Return prompts as a list, not vector - (append (json-read-from-string line) nil))))) + ;; Return prompts as a list. + (python--parse-json-array line))))) ;; The list must contain 3 strings, where the first ;; is the input prompt, the second is the block ;; prompt and the last one is the output prompt. The @@ -3785,7 +3798,7 @@ the top stack frame has been reached. Filename is expected in the first parenthesized expression. Line number is expected in the second parenthesized expression." - :type 'string + :type 'regexp :version "27.1" :safe 'stringp) @@ -4560,7 +4573,7 @@ returns will be used. If not FORCE-PROCESS is passed what :type 'boolean :version "25.1") -(defun python-eldoc-function () +(defun python-eldoc-function (&rest _ignored) "`eldoc-documentation-function' for Python. For this to work as best as possible you should call `python-shell-send-buffer' from time to time so context in @@ -5540,12 +5553,16 @@ REPORT-FN is Flymake's callback function." (current-column)))) (^ '(- (1+ (current-indentation)))))) - (if (null eldoc-documentation-function) - ;; Emacs<25 - (set (make-local-variable 'eldoc-documentation-function) - #'python-eldoc-function) - (add-function :before-until (local 'eldoc-documentation-function) - #'python-eldoc-function)) + (with-no-warnings + ;; supress warnings about eldoc-documentation-function being obsolete + (if (null eldoc-documentation-function) + ;; Emacs<25 + (set (make-local-variable 'eldoc-documentation-function) + #'python-eldoc-function) + (if (boundp 'eldoc-documentation-functions) + (add-hook 'eldoc-documentation-functions #'python-eldoc-function nil t) + (add-function :before-until (local 'eldoc-documentation-function) + #'python-eldoc-function)))) (add-to-list 'hs-special-modes-alist diff --git a/lisp/progmodes/ruby-mode.el b/lisp/progmodes/ruby-mode.el index 5da5577c108..e16225c7fa9 100644 --- a/lisp/progmodes/ruby-mode.el +++ b/lisp/progmodes/ruby-mode.el @@ -801,7 +801,7 @@ The style of the comment is controlled by `ruby-encoding-magic-comment-style'." (let ((coding-system (ruby--detect-encoding))) (when coding-system (if (looking-at "^#!") (beginning-of-line 2)) - (cond ((looking-at "\\s *#\\s *.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)") + (cond ((looking-at "\\s *#.*\\(en\\)?coding\\s *:\\s *\\([-a-z0-9_]*\\)") ;; update existing encoding comment if necessary (unless (string= (match-string 2) coding-system) (goto-char (match-beginning 2)) diff --git a/lisp/progmodes/scheme.el b/lisp/progmodes/scheme.el index 751d7da5427..33ba0d11d80 100644 --- a/lisp/progmodes/scheme.el +++ b/lisp/progmodes/scheme.el @@ -116,7 +116,7 @@ (defvar scheme-imenu-generic-expression '((nil - "^(define\\(\\|-\\(generic\\(\\|-procedure\\)\\|method\\)\\)*\\s-+(?\\(\\sw+\\)" 4) + "^(define\\(?:-\\(?:generic\\(?:-procedure\\)?\\|method\\)\\)?\\s-+(?\\(\\sw+\\)" 1) ("Types" "^(define-class\\s-+(?\\(\\sw+\\)" 1) ("Macros" diff --git a/lisp/progmodes/sh-script.el b/lisp/progmodes/sh-script.el index cc6d5b46ed2..044d7820ee3 100644 --- a/lisp/progmodes/sh-script.el +++ b/lisp/progmodes/sh-script.el @@ -64,61 +64,10 @@ ;; * Indent right half sh-basic-offset ;; / Indent left half sh-basic-offset. ;; -;; There are 4 commands to help set the indentation variables: -;; -;; `sh-show-indent' -;; This shows what variable controls the indentation of the current -;; line and its value. -;; -;; `sh-set-indent' -;; This allows you to set the value of the variable controlling the -;; current line's indentation. You can enter a number or one of a -;; number of special symbols to denote the value of sh-basic-offset, -;; or its negative, or half it, or twice it, etc. If you've used -;; cc-mode this should be familiar. If you forget which symbols are -;; valid simply press C-h at the prompt. -;; -;; `sh-learn-line-indent' -;; Simply make the line look the way you want it, then invoke this -;; command. It will set the variable to the value that makes the line -;; indent like that. If called with a prefix argument then it will set -;; the value to one of the symbols if applicable. -;; -;; `sh-learn-buffer-indent' -;; This is the deluxe function! It "learns" the whole buffer (use -;; narrowing if you want it to process only part). It outputs to a -;; buffer *indent* any conflicts it finds, and all the variables it has -;; learned. This buffer is a sort of Occur mode buffer, allowing you to -;; easily find where something was set. It is popped to automatically -;; if there are any conflicts found or if `sh-popup-occur-buffer' is -;; non-nil. -;; `sh-indent-comment' will be set if all comments follow the same -;; pattern; if they don't it will be set to nil. -;; Whether `sh-basic-offset' is set is determined by variable -;; `sh-learn-basic-offset'. -;; -;; Unfortunately, `sh-learn-buffer-indent' can take a long time to run -;; (e.g. if there are large case statements). Perhaps it does not make -;; sense to run it on large buffers: if lots of lines have different -;; indentation styles it will produce a lot of diagnostics in the -;; *indent* buffer; if there is a consistent style then running -;; `sh-learn-buffer-indent' on a small region of the buffer should -;; suffice. -;; ;; Saving indentation values ;; ------------------------- -;; After you've learned the values in a buffer, how to you remember -;; them? Originally I had hoped that `sh-learn-buffer-indent' -;; would make this unnecessary; simply learn the values when you visit -;; the buffer. -;; You can do this automatically like this: -;; (add-hook 'sh-set-shell-hook #'sh-learn-buffer-indent) -;; -;; However... `sh-learn-buffer-indent' is extremely slow, -;; especially on large-ish buffer. Also, if there are conflicts the -;; "last one wins" which may not produce the desired setting. -;; -;; So...There is a minimal way of being able to save indentation values and +;; After you've learned the values in a buffer, how to you remember them? +;; There is a minimal way of being able to save indentation values and ;; to reload them in another buffer or at another point in time. ;; ;; Use `sh-name-style' to give a name to the indentation settings of @@ -132,7 +81,7 @@ ;; Indentation variables - buffer local or global? ;; ---------------------------------------------- ;; I think that often having them buffer-local makes sense, -;; especially if one is using `sh-learn-buffer-indent'. However, if +;; especially if one is using `smie-config-guess'. However, if ;; a user sets values using customization, these changes won't appear ;; to work if the variables are already local! ;; @@ -175,18 +124,10 @@ ;; - Indenting many lines is slow. It currently does each line ;; independently, rather than saving state information. ;; -;; - `sh-learn-buffer-indent' is extremely slow. -;; -;; - "case $x in y) echo ;; esac)" the last ) is mis-identified as being -;; part of a case-pattern. You need to add a semi-colon after "esac" to -;; coerce sh-script into doing the right thing. -;; ;; - "echo $z in ps | head)" the last ) is mis-identified as being part of ;; a case-pattern. You need to put the "in" between quotes to coerce ;; sh-script into doing the right thing. ;; -;; - A line starting with "}>foo" is not indented like "} >foo". -;; ;; Richard Sharman <rsharman@pobox.com> June 1999. ;;; Code: @@ -474,10 +415,10 @@ This is buffer-local in every such buffer.") (define-key map "\C-c\C-i" 'sh-if) (define-key map "\C-c\C-f" 'sh-for) (define-key map "\C-c\C-c" 'sh-case) - (define-key map "\C-c?" 'sh-show-indent) - (define-key map "\C-c=" 'sh-set-indent) - (define-key map "\C-c<" 'sh-learn-line-indent) - (define-key map "\C-c>" 'sh-learn-buffer-indent) + (define-key map "\C-c?" #'smie-config-show-indent) + (define-key map "\C-c=" #'smie-config-set-indent) + (define-key map "\C-c<" #'smie-config-set-indent) + (define-key map "\C-c>" #'smie-config-guess) (define-key map "\C-c\C-\\" 'sh-backslash-region) (define-key map "\C-c+" 'sh-add) @@ -493,17 +434,14 @@ This is buffer-local in every such buffer.") (define-key map [remap backward-sentence] 'sh-beginning-of-command) (define-key map [remap forward-sentence] 'sh-end-of-command) (define-key map [menu-bar sh-script] (cons "Sh-Script" menu-map)) - (define-key menu-map [sh-learn-buffer-indent] - '(menu-item "Learn buffer indentation" sh-learn-buffer-indent + (define-key menu-map [smie-config-guess] + '(menu-item "Learn buffer indentation" smie-config-guess :help "Learn how to indent the buffer the way it currently is.")) - (define-key menu-map [sh-learn-line-indent] - '(menu-item "Learn line indentation" sh-learn-line-indent - :help "Learn how to indent a line as it currently is indented")) - (define-key menu-map [sh-show-indent] - '(menu-item "Show indentation" sh-show-indent + (define-key menu-map [smie-config-show-indent] + '(menu-item "Show indentation" smie-config-show-indent :help "Show the how the current line would be indented")) - (define-key menu-map [sh-set-indent] - '(menu-item "Set indentation" sh-set-indent + (define-key menu-map [smie-config-set-indent] + '(menu-item "Set indentation" smie-config-set-indent :help "Set the indentation for the current line")) (define-key menu-map [sh-pair] @@ -1158,7 +1096,7 @@ subshells can nest." (")" (0 (sh-font-lock-paren (match-beginning 0)))) ;; Highlight (possibly nested) subshells inside "" quoted ;; regions correctly. - ("\"\\(?:\\(?:[^\\\"]\\|\\\\.\\)*?\\)??\\(\\$(\\|`\\)" + ("\"\\(?:[^\\\"]\\|\\\\.\\)*?\\(\\$(\\|`\\)" (1 (ignore (if (nth 8 (save-excursion (syntax-ppss (match-beginning 0)))) (goto-char (1+ (match-beginning 0))) @@ -1196,20 +1134,8 @@ and command `sh-reset-indent-vars-to-global-values'." :options '(sh-electric-here-document-mode) :group 'sh-script) -(defcustom sh-learn-basic-offset nil - "When `sh-guess-basic-offset' should learn `sh-basic-offset'. - -nil mean: never. -t means: only if there seems to be an obvious value. -Anything else means: whenever we have a \"good guess\" as to the value." - :type '(choice - (const :tag "Never" nil) - (const :tag "Only if sure" t) - (const :tag "If have a good guess" usually)) - :group 'sh-indentation) - (defcustom sh-popup-occur-buffer nil - "Controls when `sh-learn-buffer-indent' pops the `*indent*' buffer. + "Controls when `smie-config-guess' pops the `*indent*' buffer. If t it is always shown. If nil, it is shown only when there are conflicts." :type '(choice @@ -1217,14 +1143,6 @@ are conflicts." (const :tag "Always" t)) :group 'sh-indentation) -(defcustom sh-blink t - "If non-nil, `sh-show-indent' shows the line indentation is relative to. -The position on the line is not necessarily meaningful. -In some cases the line will be the matching keyword, but this is not -always the case." - :type 'boolean - :group 'sh-indentation) - (defcustom sh-first-lines-indent 0 "The indentation of the first non-blank non-comment line. Usually 0 meaning first column. @@ -1567,11 +1485,9 @@ following commands are available, based on the current shell's syntax: \\[sh-while] while loop For sh and rc shells indentation commands are: -\\[sh-show-indent] Show the variable controlling this line's indentation. -\\[sh-set-indent] Set then variable controlling this line's indentation. -\\[sh-learn-line-indent] Change the indentation variable so this line -would indent to the way it currently is. -\\[sh-learn-buffer-indent] Set the indentation variables so the +\\[smie-config-show-indent] Show the rules controlling this line's indentation. +\\[smie-config-set-indent] Change the rules controlling this line's indentation. +\\[smie-config-guess] Try to tweak the indentation rules so the buffer indents as it currently is indented. @@ -1738,13 +1654,6 @@ This adds rules for comments and assignments." (require 'smie) -;; The SMIE code should generally be preferred, but it currently does not obey -;; the various indentation custom-vars, and it misses some important features -;; of the old code, mostly: sh-learn-line/buffer-indent, sh-show-indent, -;; sh-name/save/load-style. -(defvar sh-use-smie t - "Whether to use the SMIE code for navigation and indentation.") - (defun sh-smie--keyword-p () "Non-nil if we're at a keyword position. A keyword position is one where if we're looking at something that looks @@ -2279,60 +2188,6 @@ Point should be before the newline." (defvar sh-regexp-for-done nil "A buffer-local regexp to match opening keyword for done.") -(defvar sh-kw-alist nil - "A buffer-local, since it is shell-type dependent, list of keywords.") - -;; ( key-word first-on-this on-prev-line ) -;; This is used to set `sh-kw-alist' which is a list of sublists each -;; having 3 elements: -;; a keyword -;; a rule to check when the keyword appears on "this" line -;; a rule to check when the keyword appears on "the previous" line -;; The keyword is usually a string and is the first word on a line. -;; If this keyword appears on the line whose indentation is to be -;; calculated, the rule in element 2 is called. If this returns -;; non-zero, the resulting point (which may be changed by the rule) -;; is used as the default indentation. -;; If it returned false or the keyword was not found in the table, -;; then the keyword from the previous line is looked up and the rule -;; in element 3 is called. In this case, however, -;; `sh-get-indent-info' does not stop but may keep going and test -;; other keywords against rules in element 3. This is because the -;; preceding line could have, for example, an opening "if" and an -;; opening "while" keyword and we need to add the indentation offsets -;; for both. -;; -(defconst sh-kw - '((sh - ("if" nil sh-handle-prev-if) - ("elif" sh-handle-this-else sh-handle-prev-else) - ("else" sh-handle-this-else sh-handle-prev-else) - ("fi" sh-handle-this-fi sh-handle-prev-fi) - ("then" sh-handle-this-then sh-handle-prev-then) - ("(" nil sh-handle-prev-open) - ("{" nil sh-handle-prev-open) - ("[" nil sh-handle-prev-open) - ("}" sh-handle-this-close nil) - (")" sh-handle-this-close nil) - ("]" sh-handle-this-close nil) - ("case" nil sh-handle-prev-case) - ("esac" sh-handle-this-esac sh-handle-prev-esac) - (case-label nil sh-handle-after-case-label) ;; ??? - (";;" nil sh-handle-prev-case-alt-end) ;; ??? - (";;&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics. - (";&" nil sh-handle-prev-case-alt-end) ;Like ";;" with diff semantics. - ("done" sh-handle-this-done sh-handle-prev-done) - ("do" sh-handle-this-do sh-handle-prev-do)) - - ;; Note: we don't need specific stuff for bash and zsh shells; - ;; the regexp `sh-regexp-for-done' handles the extra keywords - ;; these shells use. - (rc - ("{" nil sh-handle-prev-open) - ("}" sh-handle-this-close nil) - ("case" sh-handle-this-rc-case sh-handle-prev-rc-case)))) - - (defun sh-set-shell (shell &optional no-query-flag insert-flag) "Set this buffer's shell to SHELL (a string). @@ -2400,16 +2255,6 @@ whose value is the shell name (don't quote it)." (funcall mksym "rules") :forward-token (funcall mksym "forward-token") :backward-token (funcall mksym "backward-token"))) - (unless sh-use-smie - (setq-local sh-kw-alist (sh-feature sh-kw)) - (let ((regexp (sh-feature sh-kws-for-done))) - (if regexp - (setq-local sh-regexp-for-done - (sh-mkword-regexpr (regexp-opt regexp t))))) - (message "setting up indent stuff") - ;; sh-mode has already made indent-line-function local - ;; but do it in case this is called before that. - (setq-local indent-line-function #'sh-indent-line)) (if sh-make-vars-local (sh-make-vars-local)) (message "Indentation setup for shell type %s" sh-shell)) @@ -2564,11 +2409,6 @@ region, clear header." (eq -1 (% (save-excursion (skip-chars-backward "\\\\")) 2))) ;; Indentation stuff. -(defun sh-must-support-indent () - "Signal an error if the shell type for this buffer is not supported. -Also, the buffer must be in Shell-script mode." - (unless sh-indent-supported-here - (error "This buffer's shell does not support indentation through Emacs"))) (defun sh-make-vars-local () "Make the indentation variables local to this buffer. @@ -2589,654 +2429,12 @@ Then, if variable `sh-make-vars-local' is non-nil, make them local." (if sh-make-vars-local (mapcar 'make-local-variable sh-var-list))) - -;; Theoretically these are only needed in shell and derived modes. -;; However, the routines which use them are only called in those modes. -(defconst sh-special-keywords "then\\|do") - -(defun sh-help-string-for-variable (var) - "Construct a string for `sh-read-variable' when changing variable VAR ." - (let ((msg (documentation-property var 'variable-documentation)) - (msg2 "")) - (unless (memq var '(sh-first-lines-indent sh-indent-comment)) - (setq msg2 - (format "\n -You can enter a number (positive to increase indentation, -negative to decrease indentation, zero for no change to indentation). - -Or, you can enter one of the following symbols which are relative to -the value of variable `sh-basic-offset' -which in this buffer is currently %s. - -\t%s." - sh-basic-offset - (mapconcat (lambda (x) - (nth (1- (length x)) x)) - sh-symbol-list "\n\t")))) - (concat - ;; The following shows the global not the local value! - ;; (format "Current value of %s is %s\n\n" var (symbol-value var)) - msg msg2))) - -(defun sh-read-variable (var) - "Read a new value for indentation variable VAR." - (let ((minibuffer-help-form `(sh-help-string-for-variable - (quote ,var))) - val) - (setq val (read-from-minibuffer - (format "New value for %s (press %s for help): " - var (single-key-description help-char)) - (format "%s" (symbol-value var)) - nil t)) - val)) - - - (defun sh-in-comment-or-string (start) "Return non-nil if START is in a comment or string." (save-excursion (let ((state (syntax-ppss start))) (or (nth 3 state) (nth 4 state))))) -(defun sh-goto-matching-if () - "Go to the matching if for a fi. -This handles nested if..fi pairs." - (let ((found (sh-find-prev-matching "\\bif\\b" "\\bfi\\b" 1))) - (if found - (goto-char found)))) - - -;; Functions named sh-handle-this-XXX are called when the keyword on the -;; line whose indentation is being handled contain XXX; -;; those named sh-handle-prev-XXX are when XXX appears on the previous line. - -(defun sh-handle-prev-if () - (list '(+ sh-indent-after-if))) - -(defun sh-handle-this-else () - (if (sh-goto-matching-if) - ;; (list "aligned to if") - (list "aligned to if" '(+ sh-indent-for-else)) - nil - )) - -(defun sh-handle-prev-else () - (if (sh-goto-matching-if) - (list '(+ sh-indent-after-if)) - )) - -(defun sh-handle-this-fi () - (if (sh-goto-matching-if) - (list "aligned to if" '(+ sh-indent-for-fi)) - nil - )) - -(defun sh-handle-prev-fi () - ;; Why do we have this rule? Because we must go back to the if - ;; to get its indent. We may continue back from there. - ;; We return nil because we don't have anything to add to result, - ;; the side affect of setting align-point is all that matters. - ;; we could return a comment (a string) but I can't think of a good one... - (sh-goto-matching-if) - nil) - -(defun sh-handle-this-then () - (let ((p (sh-goto-matching-if))) - (if p - (list '(+ sh-indent-for-then)) - ))) - -(defun sh-handle-prev-then () - (let ((p (sh-goto-matching-if))) - (if p - (list '(+ sh-indent-after-if)) - ))) - -(defun sh-handle-prev-open () - (save-excursion - (let ((x (sh-prev-stmt))) - (if (and x - (progn - (goto-char x) - (or - (looking-at "function\\b") - (looking-at "\\s-*\\S-+\\s-*()") - ))) - (list '(+ sh-indent-after-function)) - (list '(+ sh-indent-after-open))) - ))) - -(defun sh-handle-this-close () - (forward-char 1) ;; move over ")" - (if (sh-safe-forward-sexp -1) - (list "aligned to opening paren"))) - -(defun sh-goto-matching-case () - (let ((found (sh-find-prev-matching "\\bcase\\b" "\\besac\\b" 1))) - (if found (goto-char found)))) - -(defun sh-handle-prev-case () - ;; This is typically called when point is on same line as a case - ;; we shouldn't -- and can't find prev-case - (if (looking-at ".*\\<case\\>") - (list '(+ sh-indent-for-case-label)) - (error "We don't seem to be on a line with a case"))) ;; debug - -(defun sh-handle-this-esac () - (if (sh-goto-matching-case) - (list "aligned to matching case"))) - -(defun sh-handle-prev-esac () - (if (sh-goto-matching-case) - (list "matching case"))) - -(defun sh-handle-after-case-label () - (if (sh-goto-matching-case) - (list '(+ sh-indent-for-case-alt)))) - -(defun sh-handle-prev-case-alt-end () - (if (sh-goto-matching-case) - (list '(+ sh-indent-for-case-label)))) - -(defun sh-safe-forward-sexp (&optional arg) - "Try and do a `forward-sexp', but do not error. -Return new point if successful, nil if an error occurred." - (condition-case nil - (progn - (forward-sexp (or arg 1)) - (point)) ;; return point if successful - (error - (sh-debug "oops!(1) %d" (point)) - nil))) ;; return nil if fail - -(defun sh-goto-match-for-done () - (let ((found (sh-find-prev-matching sh-regexp-for-done sh-re-done 1))) - (if found - (goto-char found)))) - -(defun sh-handle-this-done () - (if (sh-goto-match-for-done) - (list "aligned to do stmt" '(+ sh-indent-for-done)))) - -(defun sh-handle-prev-done () - (if (sh-goto-match-for-done) - (list "previous done"))) - -(defun sh-handle-this-do () - (if (sh-goto-match-for-done) - (list '(+ sh-indent-for-do)))) - -(defun sh-handle-prev-do () - (cond - ((save-restriction - (narrow-to-region (point) (line-beginning-position)) - (sh-goto-match-for-done)) - (sh-debug "match for done found on THIS line") - (list '(+ sh-indent-after-loop-construct))) - ((sh-goto-match-for-done) - (sh-debug "match for done found on PREV line") - (list '(+ sh-indent-after-do))) - (t - (message "match for done NOT found") - nil))) - -;; for rc: -(defun sh-find-prev-switch () - "Find the line for the switch keyword matching this line's case keyword." - (re-search-backward "\\<switch\\>" nil t)) - -(defun sh-handle-this-rc-case () - (if (sh-find-prev-switch) - (list '(+ sh-indent-after-switch)) - ;; (list '(+ sh-indent-for-case-label)) - nil)) - -(defun sh-handle-prev-rc-case () - (list '(+ sh-indent-after-case))) - -(defun sh-check-rule (n thing) - (let ((rule (nth n (assoc thing sh-kw-alist))) - (val nil)) - (if rule - (progn - (setq val (funcall rule)) - (sh-debug "rule (%d) for %s at %d is %s\n-> returned %s" - n thing (point) rule val))) - val)) - - -(defun sh-get-indent-info () - "Return indent-info for this line. -This is a list. nil means the line is to be left as is. -Otherwise it contains one or more of the following sublists: -\(t NUMBER) NUMBER is the base location in the buffer that indentation is - relative to. If present, this is always the first of the - sublists. The indentation of the line in question is - derived from the indentation of this point, possibly - modified by subsequent sublists. -\(+ VAR) -\(- VAR) Get the value of variable VAR and add to or subtract from - the indentation calculated so far. -\(= VAR) Get the value of variable VAR and *replace* the - indentation with its value. This only occurs for - special variables such as `sh-indent-comment'. -STRING This is ignored for the purposes of calculating - indentation, it is printed in certain cases to help show - what the indentation is based on." - ;; See comments before `sh-kw'. - (save-excursion - (let ((have-result nil) - this-kw - val - (result nil) - (align-point nil) - prev-line-end x) - (beginning-of-line) - ;; Note: setting result to t means we are done and will return nil. - ;;(This function never returns just t.) - (cond - ((or (nth 3 (syntax-ppss (point))) - (eq (get-text-property (point) 'face) 'sh-heredoc)) - ;; String continuation -- don't indent - (setq result t) - (setq have-result t)) - ((looking-at "\\s-*#") ; was (equal this-kw "#") - (if (bobp) - (setq result t) ;; return nil if 1st line! - (setq result (list '(= sh-indent-comment))) - ;; we still need to get previous line in case - ;; sh-indent-comment is t (indent as normal) - (setq align-point (sh-prev-line nil)) - (setq have-result nil) - )) - ) ;; cond - - (unless have-result - ;; Continuation lines are handled specially - (if (sh-this-is-a-continuation) - (progn - (setq result - (if (save-excursion - (beginning-of-line) - (not (memq (char-before (- (point) 2)) '(?\s ?\t)))) - ;; By convention, if the continuation \ is not - ;; preceded by a SPC or a TAB it means that the line - ;; is cut at a place where spaces cannot be freely - ;; added/removed. I.e. do not indent the line. - (list '(= nil)) - ;; We assume the line being continued is already - ;; properly indented... - ;; (setq prev-line-end (sh-prev-line)) - (setq align-point (sh-prev-line nil)) - (list '(+ sh-indent-for-continuation)))) - (setq have-result t)) - (beginning-of-line) - (skip-chars-forward " \t") - (setq this-kw (sh-get-kw))) - - ;; Handle "this" keyword: first word on the line we're - ;; calculating indentation info for. - (if this-kw - (if (setq val (sh-check-rule 1 this-kw)) - (progn - (setq align-point (point)) - (sh-debug - "this - setting align-point to %d" align-point) - (setq result (append result val)) - (setq have-result t) - ;; set prev-line to continue processing remainder - ;; of this line as a previous line - (setq prev-line-end (point)) - )))) - - (unless have-result - (setq prev-line-end (sh-prev-line 'end))) - - (if prev-line-end - (save-excursion - ;; We start off at beginning of this line. - ;; Scan previous statements while this is <= - ;; start of previous line. - (goto-char prev-line-end) - (setq x t) - (while (and x (setq x (sh-prev-thing))) - (sh-debug "at %d x is: %s result is: %s" (point) x result) - (cond - ((and (equal x ")") - (equal (get-text-property (1- (point)) 'syntax-table) - sh-st-punc)) - (sh-debug "Case label) here") - (setq x 'case-label) - (if (setq val (sh-check-rule 2 x)) - (progn - (setq result (append result val)) - (setq align-point (point)))) - (or (bobp) - (forward-char -1)) - (skip-chars-forward "*0-9?[]a-z") - ) - ((string-match "[])}]" x) - (setq x (sh-safe-forward-sexp -1)) - (if x - (progn - (setq align-point (point)) - (setq result (append result - (list "aligned to opening paren"))) - ))) - ((string-match "[[({]" x) - (sh-debug "Checking special thing: %s" x) - (if (setq val (sh-check-rule 2 x)) - (setq result (append result val))) - (forward-char -1) - (setq align-point (point))) - ((string-match "[\"'`]" x) - (sh-debug "Skipping back for %s" x) - ;; this was oops-2 - (setq x (sh-safe-forward-sexp -1))) - ((stringp x) - (sh-debug "Checking string %s at %s" x (point)) - (if (setq val (sh-check-rule 2 x)) - ;; (or (eq t (car val)) - ;; (eq t (car (car val)))) - (setq result (append result val))) - ;; not sure about this test Wed Jan 27 23:48:35 1999 - (setq align-point (point)) - (unless (bolp) - (forward-char -1))) - (t - (error "Don't know what to do with %s" x)) - ) - ) ;; while - (sh-debug "result is %s" result) - ) - (sh-debug "No prev line!") - (sh-debug "result: %s align-point: %s" result align-point) - ) - - (if align-point - ;; was: (setq result (append result (list (list t align-point)))) - (setq result (append (list (list t align-point)) result)) - ) - (sh-debug "result is now: %s" result) - - (or result - (setq result (list (if prev-line-end - (list t prev-line-end) - (list '= 'sh-first-lines-indent))))) - - (if (eq result t) - (setq result nil)) - (sh-debug "result is: %s" result) - result - ) ;; let - )) - - -(defun sh-get-indent-var-for-line (&optional info) - "Return the variable controlling indentation for this line. -If there is not [just] one such variable, return a string -indicating the problem. -If INFO is supplied it is used, else it is calculated." - (let ((var nil) - (result nil) - (reason nil) - sym elt) - (or info - (setq info (sh-get-indent-info))) - (if (null info) - (setq result "this line to be left as is") - (while (and info (null result)) - (setq elt (car info)) - (cond - ((stringp elt) - (setq reason elt) - ) - ((not (listp elt)) - (error "sh-get-indent-var-for-line invalid elt: %s" elt)) - ;; so it is a list - ((eq t (car elt)) - ) ;; nothing - ((symbolp (setq sym (nth 1 elt))) - ;; A bit of a kludge - when we see the sh-indent-comment - ;; ignore other variables. Otherwise it is tricky to - ;; "learn" the comment indentation. - (if (eq var 'sh-indent-comment) - (setq result var) - (if var - (setq result - "this line is controlled by more than 1 variable.") - (setq var sym)))) - (t - (error "sh-get-indent-var-for-line invalid list elt: %s" elt))) - (setq info (cdr info)) - )) - (or result - (setq result var)) - (or result - (setq result reason)) - (if (null result) - ;; e.g. just had (t POS) - (setq result "line has default indentation")) - result)) - - - -;; Finding the previous line isn't trivial. -;; We must *always* go back one more and see if that is a continuation -;; line -- it is the PREVIOUS line which is continued, not the one -;; we are going to! -;; Also, we want to treat a whole "here document" as one big line, -;; because we may want to align to the beginning of it. -;; -;; What we do: -;; - go back to previous non-empty line -;; - if this is in a here-document, go to the beginning of it -;; - while previous line is continued, go back one line -(defun sh-prev-line (&optional end) - "Back to end of previous non-comment non-empty line. -Go to beginning of logical line unless END is non-nil, in which case -we go to the end of the previous line and do not check for continuations." - (save-excursion - (beginning-of-line) - (forward-comment (- (point-max))) - (unless end (beginning-of-line)) - (when (and (not (bobp)) - (eq (get-text-property (1- (point)) 'face) 'sh-heredoc)) - (let ((p1 (previous-single-property-change (1- (point)) 'face))) - (when p1 - (goto-char p1) - (if end - (end-of-line) - (beginning-of-line))))) - (unless end - ;; we must check previous lines to see if they are continuation lines - ;; if so, we must return position of first of them - (while (and (sh-this-is-a-continuation) - (>= 0 (forward-line -1)))) - (beginning-of-line) - (skip-chars-forward " \t")) - (point))) - - -(defun sh-prev-stmt () - "Return the address of the previous stmt or nil." - ;; This is used when we are trying to find a matching keyword. - ;; Searching backward for the keyword would certainly be quicker, but - ;; it is hard to remove "false matches" -- such as if the keyword - ;; appears in a string or quote. This way is slower, but (I think) safer. - (interactive) - (save-excursion - (let ((going t) - (start (point)) - (found nil) - (prev nil)) - (skip-chars-backward " \t;|&({[") - (while (and (not found) - (not (bobp)) - going) - ;; Do a backward-sexp if possible, else backup bit by bit... - (if (sh-safe-forward-sexp -1) - (progn - (if (looking-at sh-special-keywords) - (progn - (setq found prev)) - (setq prev (point)) - )) - ;; backward-sexp failed - (if (zerop (skip-chars-backward " \t()[]{};`'")) - (forward-char -1)) - (if (bolp) - (let ((back (sh-prev-line nil))) - (if back - (goto-char back) - (setq going nil))))) - (unless found - (skip-chars-backward " \t") - (if (or (and (bolp) (not (sh-this-is-a-continuation))) - (eq (char-before) ?\;) - (looking-at "\\s-*[|&]")) - (setq found (point))))) - (if found - (goto-char found)) - (if found - (progn - (skip-chars-forward " \t|&({[") - (setq found (point)))) - (if (>= (point) start) - (progn - (debug "We didn't move!") - (setq found nil)) - (or found - (sh-debug "Did not find prev stmt."))) - found))) - - -(defun sh-get-word () - "Get a shell word skipping whitespace from point." - (interactive) - (skip-chars-forward "\t ") - (let ((start (point))) - (while - (if (looking-at "[\"'`]") - (sh-safe-forward-sexp) - ;; (> (skip-chars-forward "^ \t\n\"'`") 0) - (> (skip-chars-forward "-_$[:alnum:]") 0) - )) - (buffer-substring start (point)) - )) - -(defun sh-prev-thing () - "Return the previous thing this logical line." - ;; This is called when `sh-get-indent-info' is working backwards on - ;; the previous line(s) finding what keywords may be relevant for - ;; indenting. It moves over sexps if possible, and will stop - ;; on a ; and at the beginning of a line if it is not a continuation - ;; line. - ;; - ;; Added a kludge for ";;" - ;; Possible return values: - ;; nil - nothing - ;; a string - possibly a keyword - ;; - (if (bolp) - nil - (let ((start (point)) - (min-point (if (sh-this-is-a-continuation) - (sh-prev-line nil) - (line-beginning-position)))) - (skip-chars-backward " \t;" min-point) - (if (looking-at "\\s-*;[;&]") - ;; (message "Found ;; !") - ";;" - (skip-chars-backward "^)}];\"'`({[" min-point) - (let ((c (if (> (point) min-point) (char-before)))) - (sh-debug "stopping at %d c is %s start=%d min-point=%d" - (point) c start min-point) - (if (not (memq c '(?\n nil ?\;))) - ;; c -- return a string - (char-to-string c) - ;; Return the leading keyword of the "command" we supposedly - ;; skipped over. Maybe we skipped too far (e.g. past a `do' or - ;; `then' that precedes the actual command), so check whether - ;; we're looking at such a keyword and if so, move back forward. - (let ((boundary (point)) - kwd next) - (while - (progn - ;; Skip forward over white space newline and \ at eol. - (skip-chars-forward " \t\n\\\\" start) - (if (>= (point) start) - (progn - (sh-debug "point: %d >= start: %d" (point) start) - nil) - (if next (setq boundary next)) - (sh-debug "Now at %d start=%d" (point) start) - (setq kwd (sh-get-word)) - (if (member kwd (sh-feature sh-leading-keywords)) - (progn - (setq next (point)) - t) - nil)))) - (goto-char boundary) - kwd))))))) - - -(defun sh-this-is-a-continuation () - "Return non-nil if current line is a continuation of previous line." - (save-excursion - (and (zerop (forward-line -1)) - (looking-at ".*\\\\$") - (not (nth 4 (parse-partial-sexp (match-beginning 0) (match-end 0) - nil nil nil t)))))) - -(defun sh-get-kw (&optional where and-move) - "Return first word of line from WHERE. -If AND-MOVE is non-nil then move to end of word." - (let ((start (point))) - (if where - (goto-char where)) - (prog1 - (buffer-substring (point) - (progn (skip-chars-forward "^ \t\n;&|")(point))) - (unless and-move - (goto-char start))))) - -(defun sh-find-prev-matching (open close &optional depth) - "Find a matching token for a set of opening and closing keywords. -This takes into account that there may be nested open..close pairings. -OPEN and CLOSE are regexps denoting the tokens to be matched. -Optional parameter DEPTH (usually 1) says how many to look for." - (let ((parse-sexp-ignore-comments t) - (forward-sexp-function nil) - prev) - (setq depth (or depth 1)) - (save-excursion - (condition-case nil - (while (and - (/= 0 depth) - (not (bobp)) - (setq prev (sh-prev-stmt))) - (goto-char prev) - (save-excursion - (if (looking-at "\\\\\n") - (progn - (forward-char 2) - (skip-chars-forward " \t"))) - (cond - ((looking-at open) - (setq depth (1- depth)) - (sh-debug "found open at %d - depth = %d" (point) depth)) - ((looking-at close) - (setq depth (1+ depth)) - (sh-debug "found close - depth = %d" depth)) - (t - )))) - (error nil)) - (if (eq depth 0) - prev ;; (point) - nil) - ))) - (defun sh-var-value (var &optional ignore-error) "Return the value of variable VAR, interpreting symbols. @@ -3268,620 +2466,16 @@ IGNORE-ERROR is non-nil." "Don't know how to handle %s's value of %s" var val) 0)))) -(defun sh-set-var-value (var value &optional no-symbol) - "Set variable VAR to VALUE. -Unless optional argument NO-SYMBOL is non-nil, then if VALUE is -can be represented by a symbol then do so." - (cond - (no-symbol - (set var value)) - ((= value sh-basic-offset) - (set var '+)) - ((= value (- sh-basic-offset)) - (set var '-)) - ((eq value (* 2 sh-basic-offset)) - (set var '++)) - ((eq value (* 2 (- sh-basic-offset))) - (set var '--)) - ((eq value (/ sh-basic-offset 2)) - (set var '*)) - ((eq value (/ (- sh-basic-offset) 2)) - (set var '/)) - (t - (set var value))) - ) - - -(defun sh-calculate-indent (&optional info) - "Return the indentation for the current line. -If INFO is supplied it is used, else it is calculated from current line." - (let ((ofs 0) - (base-value 0) - elt a b val) - (or info - (setq info (sh-get-indent-info))) - (when info - (while info - (sh-debug "info: %s ofs=%s" info ofs) - (setq elt (car info)) - (cond - ((stringp elt)) ;; do nothing? - ((listp elt) - (setq a (car (car info))) - (setq b (nth 1 (car info))) - (cond - ((eq a t) - (save-excursion - (goto-char b) - (setq val (current-indentation))) - (setq base-value val)) - ((symbolp b) - (setq val (sh-var-value b)) - (cond - ((eq a '=) - (cond - ((null val) - ;; no indentation - ;; set info to nil so we stop immediately - (setq base-value nil ofs nil info nil)) - ((eq val t) (setq ofs 0)) ;; indent as normal line - (t - ;; The following assume the (t POS) come first! - (setq ofs val base-value 0) - (setq info nil)))) ;; ? stop now - ((eq a '+) (setq ofs (+ ofs val))) - ((eq a '-) (setq ofs (- ofs val))) - (t - (error "sh-calculate-indent invalid a a=%s b=%s" a b)))) - (t - (error "sh-calculate-indent invalid elt: a=%s b=%s" a b)))) - (t - (error "sh-calculate-indent invalid elt %s" elt))) - (sh-debug "a=%s b=%s val=%s base-value=%s ofs=%s" - a b val base-value ofs) - (setq info (cdr info))) - ;; return value: - (sh-debug "at end: base-value: %s ofs: %s" base-value ofs) - - (cond - ((or (null base-value)(null ofs)) - nil) - ((and (numberp base-value)(numberp ofs)) - (sh-debug "base (%d) + ofs (%d) = %d" - base-value ofs (+ base-value ofs)) - (+ base-value ofs)) ;; return value - (t - (error "sh-calculate-indent: Help. base-value=%s ofs=%s" - base-value ofs) - nil))))) +(define-obsolete-function-alias 'sh-show-indent + #'smie-config-show-indent "28.1") +(define-obsolete-function-alias 'sh-set-indent #'smie-config-set-indent "28.1") -(defun sh-indent-line () - "Indent the current line." - (interactive) - (let ((indent (sh-calculate-indent)) - (pos (- (point-max) (point)))) - (when indent - (beginning-of-line) - (skip-chars-forward " \t") - (indent-line-to indent) - ;; If initial point was within line's indentation, - ;; position after the indentation. Else stay at same point in text. - (if (> (- (point-max) pos) (point)) - (goto-char (- (point-max) pos)))))) - - -(defun sh-blink (blinkpos &optional msg) - "Move cursor momentarily to BLINKPOS and display MSG." - ;; We can get here without it being a number on first line - (if (numberp blinkpos) - (save-excursion - (goto-char blinkpos) - (if msg (message "%s" msg) (message nil)) - (sit-for blink-matching-delay)) - (if msg (message "%s" msg) (message nil)))) - -(defun sh-show-indent (arg) - "Show how the current line would be indented. -This tells you which variable, if any, controls the indentation of -this line. -If optional arg ARG is non-null (called interactively with a prefix), -a pop up window describes this variable. -If variable `sh-blink' is non-nil then momentarily go to the line -we are indenting relative to, if applicable." - (interactive "P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-show-indent) - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - (curr-indent (current-indentation)) - val msg) - (if (stringp var) - (message "%s" (setq msg var)) - (setq val (sh-calculate-indent info)) - - (if (eq curr-indent val) - (setq msg (format "%s is %s" var (symbol-value var))) - (setq msg - (if val - (format "%s (%s) would change indent from %d to: %d" - var (symbol-value var) curr-indent val) - (format "%s (%s) would leave line as is" - var (symbol-value var))) - )) - (if (and arg var) - (describe-variable var))) - (if sh-blink - (let ((info (sh-get-indent-info))) - (if (and info (listp (car info)) - (eq (car (car info)) t)) - (sh-blink (nth 1 (car info)) msg) - (message "%s" msg))) - (message "%s" msg)) - ))) +(define-obsolete-function-alias 'sh-learn-line-indent + #'smie-config-set-indent "28.1") -(defun sh-set-indent () - "Set the indentation for the current line. -If the current line is controlled by an indentation variable, prompt -for a new value for it." - (interactive) - (sh-must-support-indent) - (if sh-use-smie - (smie-config-set-indent) - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - val old-val indent-val) - (if (stringp var) - (message "Cannot set indent - %s" var) - (setq old-val (symbol-value var)) - (setq val (sh-read-variable var)) - (condition-case nil - (progn - (set var val) - (setq indent-val (sh-calculate-indent info)) - (if indent-val - (message "Variable: %s Value: %s would indent to: %d" - var (symbol-value var) indent-val) - (message "Variable: %s Value: %s would leave line as is." - var (symbol-value var))) - ;; I'm not sure about this, indenting it now? - ;; No. Because it would give the impression that an undo would - ;; restore thing, but the value has been altered. - ;; (sh-indent-line) - ) - (error - (set var old-val) - (message "Bad value for %s, restoring to previous value %s" - var old-val) - (sit-for 1) - nil)) - )))) - - -(defun sh-learn-line-indent (arg) - "Learn how to indent a line as it currently is indented. - -If there is an indentation variable which controls this line's indentation, -then set it to a value which would indent the line the way it -presently is. - -If the value can be represented by one of the symbols then do so -unless optional argument ARG (the prefix when interactive) is non-nil." - (interactive "*P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-set-indent) - ;; I'm not sure if we show allow learning on an empty line. - ;; Though it might occasionally be useful I think it usually - ;; would just be confusing. - (if (save-excursion - (beginning-of-line) - (looking-at "\\s-*$")) - (message "sh-learn-line-indent ignores empty lines.") - (let* ((info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - ival sval diff new-val - (no-symbol arg) - (curr-indent (current-indentation))) - (cond - ((stringp var) - (message "Cannot learn line - %s" var)) - ((eq var 'sh-indent-comment) - ;; This is arbitrary... - ;; - if curr-indent is 0, set to curr-indent - ;; - else if it has the indentation of a "normal" line, - ;; then set to t - ;; - else set to curr-indent. - (setq sh-indent-comment - (if (= curr-indent 0) - 0 - (let* ((sh-indent-comment t) - (val2 (sh-calculate-indent info))) - (if (= val2 curr-indent) - t - curr-indent)))) - (message "%s set to %s" var (symbol-value var)) - ) - ((numberp (setq sval (sh-var-value var))) - (setq ival (sh-calculate-indent info)) - (setq diff (- curr-indent ival)) - - (sh-debug "curr-indent: %d ival: %d diff: %d var:%s sval %s" - curr-indent ival diff var sval) - (setq new-val (+ sval diff)) - ;; I commented out this because someone might want to replace - ;; a value of `+' with the current value of sh-basic-offset - ;; or vice-versa. - ;;(if (= 0 diff) - ;; (message "No change needed!") - (sh-set-var-value var new-val no-symbol) - (message "%s set to %s" var (symbol-value var)) - ) - (t - (debug) - (message "Cannot change %s" var))))))) - - - -(defun sh-mark-init (buffer) - "Initialize a BUFFER to be used by `sh-mark-line'." - (with-current-buffer (get-buffer-create buffer) - (erase-buffer) - (occur-mode))) - - -(defun sh-mark-line (message point buffer &optional add-linenum occur-point) - "Insert MESSAGE referring to location POINT in current buffer into BUFFER. -Buffer BUFFER is in `occur-mode'. -If ADD-LINENUM is non-nil the message is preceded by the line number. -If OCCUR-POINT is non-nil then the line is marked as a new occurrence -so that `occur-next' and `occur-prev' will work." - (let ((m1 (make-marker)) - start - (line "")) - (when point - (set-marker m1 point (current-buffer)) - (if add-linenum - (setq line (format "%d: " (1+ (count-lines 1 point)))))) - (save-excursion - (if (get-buffer buffer) - (set-buffer (get-buffer buffer)) - (set-buffer (get-buffer-create buffer)) - (occur-mode) - ) - (goto-char (point-max)) - (setq start (point)) - (let ((inhibit-read-only t)) - (insert line) - (if occur-point - (setq occur-point (point))) - (insert message) - (if point - (add-text-properties - start (point) - '(mouse-face highlight - help-echo "mouse-2: go to the line where I learned this"))) - (insert "\n") - (when point - (put-text-property start (point) 'occur-target m1) - (if occur-point - (put-text-property start occur-point - 'occur-match t)) - ))))) - -;; Is this really worth having? -(defvar sh-learned-buffer-hook nil - "An abnormal hook, called with an alist of learned variables.") -;; Example of how to use sh-learned-buffer-hook -;; -;; (defun what-i-learned (list) -;; (let ((p list)) -;; (with-current-buffer "*scratch*" -;; (goto-char (point-max)) -;; (insert "(setq\n") -;; (while p -;; (insert (format " %s %s \n" -;; (nth 0 (car p)) (nth 1 (car p)))) -;; (setq p (cdr p))) -;; (insert ")\n") -;; ))) -;; -;; (add-hook 'sh-learned-buffer-hook #'what-i-learned) - - -;; Originally this was sh-learn-region-indent (beg end) -;; However, in practice this was awkward so I changed it to -;; use the whole buffer. Use narrowing if need be. -(defun sh-learn-buffer-indent (&optional arg) - "Learn how to indent the buffer the way it currently is. - -If `sh-use-smie' is non-nil, call `smie-config-guess'. -Otherwise, run the sh-script specific indent learning command, as -described below. - -Output in buffer \"*indent*\" shows any lines which have conflicting -values of a variable, and the final value of all variables learned. -When called interactively, pop to this buffer automatically if -there are any discrepancies. - -If no prefix ARG is given, then variables are set to numbers. -If a prefix arg is given, then variables are set to symbols when -applicable -- e.g. to symbol `+' if the value is that of the -basic indent. -If a positive numerical prefix is given, then `sh-basic-offset' -is set to the prefix's numerical value. -Otherwise, sh-basic-offset may or may not be changed, according -to the value of variable `sh-learn-basic-offset'. - -Abnormal hook `sh-learned-buffer-hook' if non-nil is called when the -function completes. The function is abnormal because it is called -with an alist of variables learned. - -This command can often take a long time to run." - (interactive "P") - (sh-must-support-indent) - (if sh-use-smie - (smie-config-guess) - (save-excursion - (goto-char (point-min)) - (let ((learned-var-list nil) - (out-buffer "*indent*") - (num-diffs 0) - previous-set-info - (max 17) - vec - msg - (comment-col nil) ;; number if all same, t if seen diff values - (comments-always-default t) ;; nil if we see one not default - initial-msg - (specified-basic-offset (and arg (numberp arg) - (> arg 0))) - (linenum 0) - suggested) - (setq vec (make-vector max 0)) - (sh-mark-init out-buffer) - - (if specified-basic-offset - (progn - (setq sh-basic-offset arg) - (setq initial-msg - (format "Using specified sh-basic-offset of %d" - sh-basic-offset))) - (setq initial-msg - (format "Initial value of sh-basic-offset: %s" - sh-basic-offset))) - - (while (< (point) (point-max)) - (setq linenum (1+ linenum)) - ;; (if (zerop (% linenum 10)) - (message "line %d" linenum) - ;; ) - (unless (looking-at "\\s-*$") ;; ignore empty lines! - (let* ((sh-indent-comment t) ;; info must return default indent - (info (sh-get-indent-info)) - (var (sh-get-indent-var-for-line info)) - sval ival diff new-val - (curr-indent (current-indentation))) - (cond - ((null var) - nil) - ((stringp var) - nil) - ((numberp (setq sval (sh-var-value var 'no-error))) - ;; the numberp excludes comments since sval will be t. - (setq ival (sh-calculate-indent)) - (setq diff (- curr-indent ival)) - (setq new-val (+ sval diff)) - (sh-set-var-value var new-val 'no-symbol) - (unless (looking-at "\\s-*#") ;; don't learn from comments - (if (setq previous-set-info (assoc var learned-var-list)) - (progn - ;; it was already there, is it same value ? - (unless (eq (symbol-value var) - (nth 1 previous-set-info)) - (sh-mark-line - (format "Variable %s was set to %s" - var (symbol-value var)) - (point) out-buffer t t) - (sh-mark-line - (format " but was previously set to %s" - (nth 1 previous-set-info)) - (nth 2 previous-set-info) out-buffer t) - (setq num-diffs (1+ num-diffs)) - ;; (delete previous-set-info learned-var-list) - (setcdr previous-set-info - (list (symbol-value var) (point))) - ) - ) - (setq learned-var-list - (append (list (list var (symbol-value var) - (point))) - learned-var-list))) - (if (numberp new-val) - (progn - (sh-debug - "This line's indent value: %d" new-val) - (if (< new-val 0) - (setq new-val (- new-val))) - (if (< new-val max) - (aset vec new-val (1+ (aref vec new-val)))))) - )) - ((eq var 'sh-indent-comment) - (unless (= curr-indent (sh-calculate-indent info)) - ;; this is not the default indentation - (setq comments-always-default nil) - (if comment-col ;; then we have see one before - (or (eq comment-col curr-indent) - (setq comment-col t)) ;; seen a different one - (setq comment-col curr-indent)) - )) - (t - (sh-debug "Cannot learn this line!!!") - )) - (sh-debug - "at %s learned-var-list is %s" (point) learned-var-list) - )) - (forward-line 1) - ) ;; while - (if sh-debug - (progn - (setq msg (format - "comment-col = %s comments-always-default = %s" - comment-col comments-always-default)) - ;; (message msg) - (sh-mark-line msg nil out-buffer))) - (cond - ((eq comment-col 0) - (setq msg "\nComments are all in 1st column.\n")) - (comments-always-default - (setq msg "\nComments follow default indentation.\n") - (setq comment-col t)) - ((numberp comment-col) - (setq msg (format "\nComments are in col %d." comment-col))) - (t - (setq msg "\nComments seem to be mixed, leaving them as is.\n") - (setq comment-col nil) - )) - (sh-debug msg) - (sh-mark-line msg nil out-buffer) - - (sh-mark-line initial-msg nil out-buffer t t) - - (setq suggested (sh-guess-basic-offset vec)) - - (if (and suggested (not specified-basic-offset)) - (let ((new-value - (cond - ;; t => set it if we have a single value as a number - ((and (eq sh-learn-basic-offset t) (numberp suggested)) - suggested) - ;; other non-nil => set it if only one value was found - (sh-learn-basic-offset - (if (numberp suggested) - suggested - (if (= (length suggested) 1) - (car suggested)))) - (t - nil)))) - (if new-value - (progn - (setq learned-var-list - (append (list (list 'sh-basic-offset - (setq sh-basic-offset new-value) - (point-max))) - learned-var-list)) - ;; Not sure if we need to put this line in, since - ;; it will appear in the "Learned variable settings". - (sh-mark-line - (format "Changed sh-basic-offset to: %d" sh-basic-offset) - nil out-buffer)) - (sh-mark-line - (if (listp suggested) - (format "Possible value(s) for sh-basic-offset: %s" - (mapconcat 'int-to-string suggested " ")) - (format "Suggested sh-basic-offset: %d" suggested)) - nil out-buffer)))) - - - (setq learned-var-list - (append (list (list 'sh-indent-comment comment-col (point-max))) - learned-var-list)) - (setq sh-indent-comment comment-col) - (let ((name (buffer-name))) - (sh-mark-line "\nLearned variable settings:" nil out-buffer) - (if arg - ;; Set learned variables to symbolic rather than numeric - ;; values where possible. - (dolist (learned-var (reverse learned-var-list)) - (let ((var (car learned-var)) - (val (nth 1 learned-var))) - (when (and (not (eq var 'sh-basic-offset)) - (numberp val)) - (sh-set-var-value var val))))) - (dolist (learned-var (reverse learned-var-list)) - (let ((var (car learned-var))) - (sh-mark-line (format " %s %s" var (symbol-value var)) - (nth 2 learned-var) out-buffer))) - (with-current-buffer out-buffer - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (insert - (format "Indentation values for buffer %s.\n" name) - (format "%d indentation variable%s different values%s\n\n" - num-diffs - (if (= num-diffs 1) - " has" "s have") - (if (zerop num-diffs) - "." ":")))))) - (run-hook-with-args 'sh-learned-buffer-hook learned-var-list) - (and (called-interactively-p 'any) - (or sh-popup-occur-buffer (> num-diffs 0)) - (pop-to-buffer out-buffer)))))) - -(defun sh-guess-basic-offset (vec) - "See if we can determine a reasonable value for `sh-basic-offset'. -This is experimental, heuristic and arbitrary! -Argument VEC is a vector of information collected by -`sh-learn-buffer-indent'. -Return values: - number - there appears to be a good single value - list of numbers - no obvious one, here is a list of one or more - reasonable choices - nil - we couldn't find a reasonable one." - (let* ((max (1- (length vec))) - (i 1) - (totals (make-vector max 0))) - (while (< i max) - (cl-incf (aref totals i) (* 4 (aref vec i))) - (if (zerop (% i 2)) - (cl-incf (aref totals i) (aref vec (/ i 2)))) - (if (< (* i 2) max) - (cl-incf (aref totals i) (aref vec (* i 2)))) - (setq i (1+ i))) - - (let ((x nil) - (result nil) - tot sum p) - (setq i 1) - (while (< i max) - (if (/= (aref totals i) 0) - (push (cons i (aref totals i)) x)) - (setq i (1+ i))) - - (setq x (sort (nreverse x) (lambda (a b) (> (cdr a) (cdr b))))) - (setq tot (apply '+ (append totals nil))) - (sh-debug (format "vec: %s\ntotals: %s\ntot: %d" - vec totals tot)) - (cond - ((zerop (length x)) - (message "no values!")) ;; we return nil - ((= (length x) 1) - (message "only value is %d" (car (car x))) - (setq result (car (car x)))) ;; return single value - ((> (cdr (car x)) (/ tot 2)) - ;; 1st is > 50% - (message "basic-offset is probably %d" (car (car x))) - (setq result (car (car x)))) ;; again, return a single value - ((>= (cdr (car x)) (* 2 (cdr (car (cdr x))))) - ;; 1st is >= 2 * 2nd - (message "basic-offset could be %d" (car (car x))) - (setq result (car (car x)))) - ((>= (+ (cdr (car x))(cdr (car (cdr x)))) (/ tot 2)) - ;; 1st & 2nd together >= 50% - return a list - (setq p x sum 0 result nil) - (while (and p - (<= (setq sum (+ sum (cdr (car p)))) (/ tot 2))) - (setq result (append result (list (car (car p))))) - (setq p (cdr p))) - (message "Possible choices for sh-basic-offset: %s" - (mapconcat 'int-to-string result " "))) - (t - (message "No obvious value for sh-basic-offset. Perhaps %d" - (car (car x))) - ;; result is nil here - )) - result))) +(define-obsolete-function-alias 'sh-learn-buffer-indent + #'smie-config-guess "28.1") ;; ======================================================================== diff --git a/lisp/progmodes/sql.el b/lisp/progmodes/sql.el index 400e304ecf4..c86fc59ac16 100644 --- a/lisp/progmodes/sql.el +++ b/lisp/progmodes/sql.el @@ -257,7 +257,6 @@ (defcustom sql-user "" "Default username." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-password "" @@ -265,33 +264,28 @@ If you customize this, the value will be stored in your init file. Since that is a plaintext file, this could be dangerous." :type 'string - :group 'SQL :risky t) (defcustom sql-database "" "Default database." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-server "" "Default server or host." :type 'string - :group 'SQL :safe 'stringp) (defcustom sql-port 0 "Default port for connecting to a MySQL or Postgres server." :version "24.1" :type 'number - :group 'SQL :safe 'numberp) (defcustom sql-default-directory nil "Default directory for SQL processes." :version "25.1" :type '(choice (const nil) string) - :group 'SQL :safe 'stringp) ;; Login parameter type @@ -707,9 +701,9 @@ making new SQLi sessions." (repeat :inline t (list :tab "Other" (symbol :tag " Variable Symbol") + ;; FIXME: Why "Value *Expression*"? (sexp :tag "Value Expression"))))) - :version "24.1" - :group 'SQL) + :version "24.1") (defvaralias 'sql-dialect 'sql-product) @@ -723,7 +717,6 @@ This allows highlighting buffers properly when you open them." (capitalize (symbol-name (car prod-info)))) ,(car prod-info))) sql-product-alist)) - :group 'SQL :safe 'symbolp) ;; SQL indent support @@ -735,7 +728,6 @@ SQL statements with easy customizations to support varied layout requirements. The package must be available to be loaded and activated." - :group 'SQL :link '(url-link "https://elpa.gnu.org/packages/sql-indent.html") :type 'boolean :version "27.1") @@ -851,7 +843,6 @@ host key." See `sql-password-search-wallet-function' to understand how this value is used to locate the password wallet." :type `(plist-get (symbol-plist 'auth-sources) 'custom-type) - :group 'SQL :version "27.1") (defvar sql-password-search-wallet-function #'sql-auth-source-search-wallet @@ -878,8 +869,7 @@ current input in the SQLi buffer to the process." :type '(choice (const :tag "Nothing" nil) (const :tag "The semicolon `;'" semicolon) (const :tag "The string `go' by itself" go)) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-send-terminator nil "When non-nil, add a terminator to text sent to the SQL interpreter. @@ -905,10 +895,9 @@ it automatically." (const :tag "Default Terminator" t) (string :tag "Terminator String") (cons :tag "Terminator Pattern and String" - (string :tag "Terminator Pattern") + (regexp :tag "Terminator Pattern") (string :tag "Terminator String"))) - :version "22.2" - :group 'SQL) + :version "22.2") (defvar sql-contains-names nil "When non-nil, the current buffer contains database names. @@ -932,8 +921,7 @@ buffer." :type '(choice (const :tag "Default" t) (const :tag "No display" nil) (function :tag "Display Buffer function")) - :version "27.1" - :group 'SQL) + :version "27.1") ;; imenu support for sql-mode. @@ -971,8 +959,7 @@ This is used to initialize `comint-input-ring-file-name'. Note that the size of the input history is determined by the variable `comint-input-ring-size'." :type '(choice (const :tag "none" nil) - (file)) - :group 'SQL) + (file))) (defcustom sql-input-ring-separator "\n--\n" "Separator between commands in the history file. @@ -987,21 +974,18 @@ does not have it, setting `sql-input-ring-separator' will have no effect. In that case multiline commands will be split into several commands when the input history is read, as if you had set `sql-input-ring-separator' to \"\\n\"." - :type 'string - :group 'SQL) + :type 'string) ;; The usual hooks (defcustom sql-interactive-mode-hook '(sql-indent-enable) "Hook for customizing `sql-interactive-mode'." :type 'hook - :group 'SQL :version "27.1") (defcustom sql-mode-hook '(sql-indent-enable) "Hook for customizing `sql-mode'." :type 'hook - :group 'SQL :version "27.1") (defcustom sql-set-sqli-hook '() @@ -1009,8 +993,7 @@ commands when the input history is read, as if you had set This is called by `sql-set-sqli-buffer' when the value of `sql-buffer' is changed." - :type 'hook - :group 'SQL) + :type 'hook) (defcustom sql-login-hook '() "Hook for interacting with a buffer in `sql-interactive-mode'. @@ -1018,8 +1001,7 @@ is changed." This hook is invoked in a buffer once it is ready to accept input for the first time." :version "24.1" - :type 'hook - :group 'SQL) + :type 'hook) ;; Customization for ANSI @@ -1033,8 +1015,7 @@ All products share this list; products should define a regexp to identify additional keywords in a variable defined by the :statement feature." :version "24.1" - :type 'string - :group 'SQL) + :type 'regexp) ;; Customization for Oracle @@ -1046,27 +1027,23 @@ Starts `sql-interactive-mode' after doing some setup. On Windows, \"sqlplus\" usually starts the sqlplus \"GUI\". In order to start the sqlplus console, use \"plus33\" or something similar. You will find the file in your Orant\\bin directory." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-oracle-options '("-L") "List of additional options for `sql-oracle-program'." :type '(repeat string) - :version "24.4" - :group 'SQL) + :version "24.4") (defcustom sql-oracle-login-params '(user password database) "List of login parameters needed to connect to Oracle." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") (defcustom sql-oracle-statement-starters (regexp-opt '("declare" "begin" "with")) "Additional statement starting keywords in Oracle." :version "24.1" - :type 'string - :group 'SQL) + :type 'string) (defcustom sql-oracle-scan-on t "Non-nil if placeholders should be replaced in Oracle SQLi. @@ -1082,8 +1059,7 @@ You need to issue the following command in SQL*Plus to be safe: In older versions of SQL*Plus, this was the SET SCAN OFF command." :version "24.1" - :type 'boolean - :group 'SQL) + :type 'boolean) (defcustom sql-db2-escape-newlines nil "Non-nil if newlines should be escaped by a backslash in DB2 SQLi. @@ -1092,8 +1068,7 @@ When non-nil, Emacs will automatically insert a space and backslash prior to every newline in multi-line SQL statements as they are submitted to an interactive DB2 session." :version "24.3" - :type 'boolean - :group 'SQL) + :type 'boolean) ;; Customization for SQLite @@ -1103,21 +1078,18 @@ they are submitted to an interactive DB2 session." "Command to start SQLite. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-sqlite-options nil "List of additional options for `sql-sqlite-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-sqlite-login-params '((database :file nil :must-match confirm)) "List of login parameters needed to connect to SQLite." :type 'sql-login-params - :version "26.1" - :group 'SQL) + :version "26.1") ;; Customization for MariaDB @@ -1134,22 +1106,19 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start mysql by Oracle. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-mysql-options nil "List of additional options for `sql-mysql-program'. The following list of options is reported to make things work on Windows: \"-C\" \"-t\" \"-f\" \"-n\"." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-mysql-login-params '(user password database server) "List of login parameters needed to connect to MySQL." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Solid @@ -1157,14 +1126,12 @@ on Windows: \"-C\" \"-t\" \"-f\" \"-n\"." "Command to start SOLID SQL Editor. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-solid-login-params '(user password server) "List of login parameters needed to connect to Solid." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Sybase @@ -1172,21 +1139,18 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start isql by Sybase. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-sybase-options nil "List of additional options for `sql-sybase-program'. Some versions of isql might require the -n option in order to work." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-sybase-login-params '(server user password database) "List of login parameters needed to connect to Sybase." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Informix @@ -1194,14 +1158,12 @@ Some versions of isql might require the -n option in order to work." "Command to start dbaccess by Informix. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-informix-login-params '(database) "List of login parameters needed to connect to Informix." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Ingres @@ -1209,14 +1171,12 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start sql by Ingres. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-ingres-login-params '(database) "List of login parameters needed to connect to Ingres." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Microsoft @@ -1229,21 +1189,18 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start osql by Microsoft. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-ms-options '("-w" "300" "-n") ;; -w is the linesize "List of additional options for `sql-ms-program'." :type '(repeat string) - :version "22.1" - :group 'SQL) + :version "22.1") (defcustom sql-ms-login-params '(user password server database) "List of login parameters needed to connect to Microsoft." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Postgres @@ -1251,8 +1208,7 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start psql by Postgres. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-postgres-options '("-P" "pager=off") "List of additional options for `sql-postgres-program'. @@ -1263,8 +1219,7 @@ name, add the string \"-u\" to the list of options. If you want to provide a user name on the command line (newer versions such as 7.1), add your name with a \"-U\" prefix (such as \"-Umark\") to the list." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-postgres-login-params `((user :default ,(user-login-name)) @@ -1275,8 +1230,7 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." server) "List of login parameters needed to connect to Postgres." :type 'sql-login-params - :version "26.1" - :group 'SQL) + :version "26.1") (defun sql-postgres-list-databases () "Return a list of available PostgreSQL databases." @@ -1297,20 +1251,17 @@ add your name with a \"-U\" prefix (such as \"-Umark\") to the list." "Command to start isql by Interbase. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-interbase-options nil "List of additional options for `sql-interbase-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-interbase-login-params '(user password database) "List of login parameters needed to connect to Interbase." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for DB2 @@ -1318,20 +1269,17 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start db2 by IBM. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-db2-options nil "List of additional options for `sql-db2-program'." :type '(repeat string) - :version "20.8" - :group 'SQL) + :version "20.8") (defcustom sql-db2-login-params nil "List of login parameters needed to connect to DB2." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") ;; Customization for Linter @@ -1339,20 +1287,17 @@ Starts `sql-interactive-mode' after doing some setup." "Command to start inl by RELEX. Starts `sql-interactive-mode' after doing some setup." - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-linter-options nil "List of additional options for `sql-linter-program'." :type '(repeat string) - :version "21.3" - :group 'SQL) + :version "21.3") (defcustom sql-linter-login-params '(user password database server) "Login parameters to needed to connect to Linter." :type 'sql-login-params - :version "24.1" - :group 'SQL) + :version "24.1") @@ -1436,10 +1381,7 @@ specified, it's `sql-product' or `sql-connection' must match." (defvar sql-interactive-mode-map (let ((map (make-sparse-keymap))) - (if (fboundp 'set-keymap-parent) - (set-keymap-parent map comint-mode-map); Emacs - (if (fboundp 'set-keymap-parents) - (set-keymap-parents map (list comint-mode-map)))); XEmacs + (set-keymap-parent map comint-mode-map) (if (fboundp 'set-keymap-name) (set-keymap-name map 'sql-interactive-mode-map)); XEmacs (define-key map (kbd "C-j") 'sql-accumulate-and-indent) @@ -2374,7 +2316,8 @@ function `regexp-opt'.") "ansi_warnings" "forceplan" "showplan_all" "showplan_text" "statistics" "implicit_transactions" "remote_proc_transactions" "transaction" "xact_abort" -) t) +) + t) "\\)\\)\\|go\\s-*\\|use\\s-+\\|setuser\\s-+\\|dbcc\\s-+\\).*$") 'font-lock-doc-face) @@ -2740,7 +2683,7 @@ highlighting rules in SQL mode.") nil 'require-match init 'sql-product-history init)))) -(defun sql-add-product (product display &optional plist) +(defun sql-add-product (product display &rest plist) "Add support for a database product in `sql-mode'. Add PRODUCT to `sql-product-alist' which enables `sql-mode' to @@ -2856,7 +2799,7 @@ See `sql-product-alist' for a list of products and supported features." (member feature sql-indirect-features) (not not-indirect) (symbolp v)) - (eval v) + (symbol-value v) v)) (error "`%s' is not a known product; use `sql-add-product' to add it first." product) nil))) @@ -4245,7 +4188,6 @@ must tell Emacs. Here's how to do that in your init file: \(add-hook \\='sql-mode-hook (lambda () (modify-syntax-entry ?\\\\ \".\" sql-mode-syntax-table)))" - :group 'SQL :abbrev-table sql-mode-abbrev-table (if sql-mode-menu @@ -4280,7 +4222,7 @@ must tell Emacs. Here's how to do that in your init file: (put 'sql-interactive-mode 'mode-class 'special) (put 'sql-interactive-mode 'custom-mode-group 'SQL) ;; FIXME: Why not use `define-derived-mode'? -(defun sql-interactive-mode () +(define-derived-mode sql-interactive-mode comint-mode "SQLi[?]" "Major mode to use a SQL interpreter interactively. Do not call this function by yourself. The environment must be @@ -4348,9 +4290,10 @@ you entered, right above the output it created. \(setq comint-output-filter-functions (function (lambda (STR) (comint-show-output))))" + :syntax-table sql-mode-syntax-table ;; FIXME: The doc above uses `setq' on `comint-output-filter-functions', ;; whereas hooks should be manipulated with things like `add/remove-hook'. - (delay-mode-hooks (comint-mode)) + :after-hook (sql--adjust-interactive-setup) ;; Get the `sql-product' for this interactive session. (set (make-local-variable 'sql-product) @@ -4358,14 +4301,11 @@ you entered, right above the output it created. sql-product)) ;; Setup the mode. - (setq major-mode 'sql-interactive-mode) (setq mode-name (concat "SQLi[" (or (sql-get-product-feature sql-product :name) (symbol-name sql-product)) "]")) - (use-local-map sql-interactive-mode-map) (if sql-interactive-mode-menu (easy-menu-add sql-interactive-mode-menu)) ; XEmacs - (set-syntax-table sql-mode-syntax-table) ;; Note that making KEYWORDS-ONLY nil will cause havoc if you try ;; SELECT 'x' FROM DUAL with SQL*Plus, because the title of the column @@ -4409,9 +4349,10 @@ you entered, right above the output it created. (add-hook 'comint-preoutput-filter-functions #'sql-interactive-remove-continuation-prompt nil t) (make-local-variable 'sql-input-ring-separator) - (make-local-variable 'sql-input-ring-file-name) - ;; Run the mode hook (along with comint's hooks). - (run-mode-hooks 'sql-interactive-mode-hook) + (make-local-variable 'sql-input-ring-file-name)) + +(defun sql--adjust-interactive-setup () + "Finish the mode's setup after running the mode hook." ;; Set comint based on user overrides. (setq comint-prompt-regexp (if sql-prompt-cont-regexp @@ -4490,7 +4431,7 @@ is specified in the connection settings." (dolist (vv connect-set) (let ((var (car vv)) (val (cadr vv))) - (set-default var (eval val)))) + (set-default var (eval val)))) ;FIXME: Why `eval'? (setq-default sql-connection connection) ;; :sqli-login params variable @@ -4521,10 +4462,10 @@ is specified in the connection settings." (if vals (cons var vals) var))))) ;; Start the SQLi session with revised list of login parameters - (eval `(let ((,param-var ',rem-vars)) - (sql-product-interactive - ',sql-product - ',(or buf-name (format "<%s>" connection)))))) + (cl-progv (list param-var) (list rem-vars) + (sql-product-interactive + sql-product + (or buf-name (format "<%s>" connection))))) (user-error "SQL Connection <%s> does not exist" connection) nil))) @@ -4595,7 +4536,10 @@ optionally is saved to the user's init file." (format "Connection <%s>\t%s" (car conn) (let ((sql-user "") (sql-database "") (sql-server "") (sql-port 0)) - (eval `(let ,(cdr conn) (sql-make-alternate-buffer-name))))) + (cl-progv + (mapcar #'car (cdr conn)) + (mapcar #'cadr (cdr conn)) + (sql-make-alternate-buffer-name)))) (list 'sql-connect (car conn)) t)) sql-connection-alist) @@ -4977,8 +4921,7 @@ The default comes from `process-coding-system-alist' and See the distinct values in ALL_OBJECTS.OBJECT_TYPE for possible values." :version "24.1" - :type '(repeat string) - :group 'SQL) + :type '(repeat string)) (defun sql-oracle-completion-object (sqlbuf schema) (sql-redirect-value @@ -5624,21 +5567,18 @@ buffer. (defcustom sql-vertica-program "vsql" "Command to start the Vertica client." :version "25.1" - :type 'file - :group 'SQL) + :type 'file) (defcustom sql-vertica-options '("-P" "pager=off") "List of additional options for `sql-vertica-program'. The default value disables the internal pager." :version "25.1" - :type '(repeat string) - :group 'SQL) + :type '(repeat string)) (defcustom sql-vertica-login-params '(user password database server) "List of login parameters needed to connect to Vertica." :version "25.1" - :type 'sql-login-params - :group 'SQL) + :type 'sql-login-params) (defun sql-comint-vertica (product options &optional buf-name) "Create comint buffer and connect to Vertica." diff --git a/lisp/progmodes/verilog-mode.el b/lisp/progmodes/verilog-mode.el index 460957b7161..5a469bb9677 100644 --- a/lisp/progmodes/verilog-mode.el +++ b/lisp/progmodes/verilog-mode.el @@ -9,7 +9,7 @@ ;; Keywords: languages ;; The "Version" is the date followed by the decimal rendition of the Git ;; commit hex. -;; Version: 2019.12.17.268053413 +;; Version: 2020.06.27.014326051 ;; Yoni Rabkin <yoni@rabkins.net> contacted the maintainer of this ;; file on 19/3/2008, and the maintainer agreed that when a bug is @@ -124,7 +124,7 @@ ;; ;; This variable will always hold the version number of the mode -(defconst verilog-mode-version "2019-12-17-ffa2ba5-vpo-GNU" +(defconst verilog-mode-version "2020-06-27-0da9923-vpo-GNU" "Version of this Verilog mode.") (defconst verilog-mode-release-emacs t "If non-nil, this version of Verilog mode was released with Emacs itself.") @@ -605,7 +605,7 @@ are lineup only when \\[verilog-pretty-declarations] is typed." (function :tag "Other")) :group 'verilog-mode-indent ) (put 'verilog-auto-lineup 'safe-local-variable - '(lambda (x) (memq x '(nil all assignments declarations)))) + (lambda (x) (memq x '(nil all assignments declarations)))) (defcustom verilog-indent-level 3 "Indentation of Verilog statements with respect to containing block." @@ -958,8 +958,8 @@ See `compilation-error-regexp-alist-alist' for the formatting. For XEmacs.") ("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 1 bold t) ("syntax error:.*\n\\([^ \t]+\\) *\\([0-9]+\\):" 2 bold t) ;; verilog-verilator - (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t) - (".*%?\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t) + (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 3 bold t) + (".*\\(Error\\|Warning\\)\\(-[^:]+\\|\\):[\n ]*\\([^ \t:]+\\):\\([0-9]+\\):" 4 bold t) ;; verilog-leda ("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 1 bold t) ("^In file \\([^ \t]+\\)[ \t]+line[ \t]+\\([0-9]+\\):\n[^\n]*\n[^\n]*\n\\(Warning\\|Error\\|Failure\\)[^\n]*" 2 bold t) @@ -1118,7 +1118,7 @@ SystemVerilog designs." :type 'boolean :group 'verilog-mode-auto) (put 'verilog-auto-reset-widths 'safe-local-variable - '(lambda (x) (memq x '(nil t unbased)))) + (lambda (x) (memq x '(nil t unbased)))) (defcustom verilog-assignment-delay "" "Text used for delays in delayed assignments. Add a trailing space if set." @@ -1138,7 +1138,7 @@ line." (const :tag "Line up Assignment statements" single)) :group 'verilog-mode-auto) (put 'verilog-auto-arg-format 'safe-local-variable - '(lambda (x) (memq x '(packed single)))) + (lambda (x) (memq x '(packed single)))) (defcustom verilog-auto-arg-sort nil "Non-nil means AUTOARG signal names will be sorted, not in declaration order. @@ -1263,7 +1263,7 @@ otherwise no vectors if sizes match (like using nil)." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const unsigned))) (put 'verilog-auto-inst-vector 'safe-local-variable - '(lambda (x) (memq x '(nil t unsigned)))) + (lambda (x) (memq x '(nil t unsigned)))) (defcustom verilog-auto-inst-template-numbers nil "If true, when creating templated ports with AUTOINST, add a comment. @@ -1280,7 +1280,19 @@ won't merge conflict." :group 'verilog-mode-auto :type '(choice (const nil) (const t) (const lhs))) (put 'verilog-auto-inst-template-numbers 'safe-local-variable - '(lambda (x) (memq x '(nil t lhs)))) + (lambda (x) (memq x '(nil t lhs)))) + +(defcustom verilog-auto-inst-template-required nil + "If non-nil, when creating a port with AUTOINST, require a template. +Any port which does not have a template will be ommitted from the +instantiation. + +If nil, if a port is not templated it will be inserted to connect +to a net with the same name as the port." + :version "28.0" + :group 'verilog-mode-auto + :type 'boolean) +(put 'verilog-auto-inst-template-required 'safe-local-variable 'verilog-booleanp) (defcustom verilog-auto-inst-column 40 "Indent-to column number for net name part of AUTOINST created pin." @@ -1418,7 +1430,7 @@ See also `verilog-case-fold'." :type 'hook) (defvar verilog-imenu-generic-expression - '((nil "^\\s-*\\(?:m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1) + '((nil "^\\s-*\\(?:connectmodule\\|m\\(?:odule\\|acromodule\\)\\|p\\(?:rimitive\\|rogram\\|ackage\\)\\)\\s-+\\([a-zA-Z0-9_.:]+\\)" 1) ("*Variables*" "^\\s-*\\(reg\\|wire\\|logic\\)\\s-+\\(\\|\\[[^]]+\\]\\s-+\\)\\([A-Za-z0-9_]+\\)" 3) ("*Classes*" "^\\s-*\\(?:\\(?:virtual\\|interface\\)\\s-+\\)?class\\s-+\\([A-Za-z_][A-Za-z0-9_]+\\)" 1) ("*Tasks*" "^\\s-*\\(?:\\(?:static\\|pure\\|virtual\\|local\\|protected\\)\\s-+\\)*task\\s-+\\(?:\\(?:static\\|automatic\\)\\s-+\\)?\\([A-Za-z_][A-Za-z0-9_:]+\\)" 1) @@ -2503,11 +2515,13 @@ find the errors." (eval-when-compile (verilog-regexp-words '( "begin" + "connectmodule" "else" "end" "endcase" "endclass" "endclocking" + "endconnectmodule" "endgroup" "endfunction" "endmodule" @@ -2550,6 +2564,7 @@ find the errors." "\\(sequence\\)\\|" ; 14 "\\(clocking\\)\\|" ; 15 "\\(property\\)\\|" ; 16 + "\\(connectmodule\\)\\|" ; 17 "\\)\\>\\)")) (defconst verilog-end-block-re (eval-when-compile @@ -2710,6 +2725,7 @@ find the errors." "endclass" "endclocking" "endconfig" + "endconnectmodule" "endfunction" "endgenerate" "endgroup" @@ -2728,7 +2744,7 @@ find the errors." (defconst verilog-declaration-opener (eval-when-compile (verilog-regexp-words - '("module" "begin" "task" "function")))) + '("connectmodule" "module" "begin" "task" "function")))) (defconst verilog-declaration-prefix-re (eval-when-compile @@ -2790,9 +2806,9 @@ find the errors." (defconst verilog-declaration-re-1-no-macro (concat "^" verilog-declaration-re-2-no-macro)) (defconst verilog-defun-re - (eval-when-compile (verilog-regexp-words '("macromodule" "module" "class" "program" "interface" "package" "primitive" "config")))) + (eval-when-compile (verilog-regexp-words '("macromodule" "connectmodule" "module" "class" "program" "interface" "package" "primitive" "config")))) (defconst verilog-end-defun-re - (eval-when-compile (verilog-regexp-words '("endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) + (eval-when-compile (verilog-regexp-words '("endconnectmodule" "endmodule" "endclass" "endprogram" "endinterface" "endpackage" "endprimitive" "endconfig")))) (defconst verilog-zero-indent-re (concat verilog-defun-re "\\|" verilog-end-defun-re)) (defconst verilog-inst-comment-re @@ -2824,7 +2840,7 @@ find the errors." "generate" "endgenerate" "initial" "interface" "endinterface" - "module" "macromodule" "endmodule" + "connectmodule" "module" "macromodule" "endconnectmodule" "endmodule" "package" "endpackage" "primitive" "endprimitive" "program" "endprogram" @@ -2892,14 +2908,14 @@ find the errors." (defconst verilog-defun-level-not-generate-re (eval-when-compile (verilog-regexp-words - '( "module" "macromodule" "primitive" "class" "program" + '( "connectmodule" "module" "macromodule" "primitive" "class" "program" "interface" "package" "config")))) (defconst verilog-defun-level-re (eval-when-compile (verilog-regexp-words (append - '( "module" "macromodule" "primitive" "class" "program" + '( "connectmodule" "module" "macromodule" "primitive" "class" "program" "interface" "package" "config") '( "initial" "final" "always" "always_comb" "always_ff" "always_latch" "endtask" "endfunction" ))))) @@ -2914,7 +2930,7 @@ find the errors." (eval-when-compile (verilog-regexp-words '( - "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass" + "endconnectmodule" "endmodule" "endprimitive" "endinterface" "endpackage" "endprogram" "endclass" )))) (defconst verilog-dpi-import-export-re @@ -2935,7 +2951,7 @@ find the errors." (eval-when-compile (verilog-regexp-words '( - "always" "assign" "always_latch" "always_ff" "always_comb" "constraint" + "always" "assign" "always_latch" "always_ff" "always_comb" "connectmodule" "constraint" "import" "initial" "final" "module" "macromodule" "repeat" "randcase" "while" "if" "for" "forever" "foreach" "else" "parameter" "do" "localparam" "assert" )))) @@ -3053,6 +3069,8 @@ find the errors." "sync_reject_on" "unique0" "until" "until_with" "untyped" "weak" ;; 1800-2012 "implements" "interconnect" "nettype" "soft" + ;; AMS + "connectmodule" "endconnectmodule" )) "List of Verilog keywords.") @@ -3117,7 +3135,7 @@ See also `verilog-font-lock-extra-types'.") (:foreground "DimGray" :italic t)) (((class grayscale) (background dark)) (:foreground "LightGray" :italic t)) - (t (:italis t))) + (t (:italic t))) "Font lock mode face used to background highlight translate-off regions." :group 'font-lock-highlighting-faces) @@ -3199,7 +3217,7 @@ See also `verilog-font-lock-extra-types'.") "atan2" "atanh" "branch" "ceil" "connect" "connectmodule" "connectrules" "continuous" "cos" "cosh" "ddt" "ddt_nature" "ddx" "discipline" "discrete" "domain" "driver_update" - "endconnectrules" "enddiscipline" "endnature" "endparamset" + "endconnectmodule" "endconnectrules" "enddiscipline" "endnature" "endparamset" "exclude" "exp" "final_step" "flicker_noise" "floor" "flow" "from" "ground" "hypot" "idt" "idt_nature" "idtmod" "inf" "initial_step" "laplace_nd" "laplace_np" "laplace_zd" @@ -3278,9 +3296,9 @@ See also `verilog-font-lock-extra-types'.") (list ;; Fontify module definitions (list - "\\<\\(\\(macro\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)" + "\\<\\(\\(macro\\|connect\\)?module\\|primitive\\|class\\|program\\|interface\\|package\\|task\\)\\>\\s-*\\(\\sw+\\)" '(1 font-lock-keyword-face) - '(3 font-lock-function-name-face 'prepend)) + '(3 font-lock-function-name-face prepend)) ;; Fontify function definitions (list (concat "\\<function\\>\\s-+\\(integer\\|real\\(time\\)?\\|time\\)\\s-+\\(\\sw+\\)" ) @@ -3290,7 +3308,16 @@ See also `verilog-font-lock-extra-types'.") (1 font-lock-keyword-face) (2 font-lock-constant-face append)) '("\\<function\\>\\s-+\\(\\sw+\\)" - 1 'font-lock-constant-face append)))) + 1 'font-lock-constant-face append) + ;; Fontify variable names in declarations + (list ;; Implemented as an anchored-matcher + (concat verilog-declaration-re + " *\\(" verilog-range-re "\\)?") + (list ;; anchored-highlighter + (concat "\\_<\\(" verilog-symbol-re "\\)" + " *\\(" verilog-range-re "\\)?*") + nil nil '(1 font-lock-variable-name-face)))))) + (setq verilog-font-lock-keywords-2 (append verilog-font-lock-keywords-1 @@ -3596,7 +3623,7 @@ Use filename, if current buffer being edited shorten to just buffer name." (setq found 't)))))) ((looking-at verilog-end-block-re) (verilog-leap-to-head)) - ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)") + ((looking-at "\\(endmodule\\>\\)\\|\\(\\<endprimitive\\>\\)\\|\\(\\<endclass\\>\\)\\|\\(\\<endprogram\\>\\)\\|\\(\\<endinterface\\>\\)\\|\\(\\<endpackage\\>\\)\\|\\(\\<endconnectmodule\\>\\)") (cond ((match-end 1) (verilog-re-search-backward "\\<\\(macro\\)?module\\>" nil 'move)) @@ -3610,6 +3637,8 @@ Use filename, if current buffer being edited shorten to just buffer name." (verilog-re-search-backward "\\<interface\\>" nil 'move)) ((match-end 6) (verilog-re-search-backward "\\<package\\>" nil 'move)) + ((match-end 7) + (verilog-re-search-backward "\\<connectmodule\\>" nil 'move)) (t (goto-char st) (backward-sexp 1)))) @@ -3735,7 +3764,8 @@ Use filename, if current buffer being edited shorten to just buffer name." "\\(\\<class\\>\\)\\|" "\\(\\<program\\>\\)\\|" "\\(\\<interface\\>\\)\\|" - "\\(\\<package\\>\\)")) + "\\(\\<package\\>\\)\\|" + "\\(\\<connectmodule\\>\\)")) (cond ((match-end 1) (verilog-re-search-forward "\\<endmodule\\>" nil 'move)) @@ -3749,6 +3779,8 @@ Use filename, if current buffer being edited shorten to just buffer name." (verilog-re-search-forward "\\<endinterface\\>" nil 'move)) ((match-end 6) (verilog-re-search-forward "\\<endpackage\\>" nil 'move)) + ((match-end 7) + (verilog-re-search-forward "\\<endconnectmodule\\>" nil 'move)) (t (goto-char st) (if (= (following-char) ?\) ) @@ -4556,13 +4588,13 @@ More specifically, point @ in the line foo : @ begin" (let ((nest 1)) (while t (verilog-re-search-backward - (concat "\\(\\<module\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|" + (concat "\\(\\<module\\>\\)\\|\\(\\<connectmodule\\>\\)\\|\\(\\<randcase\\>\\|\\<case[xz]?\\>[^:]\\)\\|" "\\(\\<endcase\\>\\)\\>") nil 'move) (cond - ((match-end 3) + ((match-end 4) (setq nest (1+ nest))) - ((match-end 2) + ((match-end 3) (if (= nest 1) (throw 'found 1)) (setq nest (1- nest))) @@ -4571,9 +4603,11 @@ More specifically, point @ in the line foo : @ begin" nil))) (defun verilog-backward-up-list (arg) - "Call `backward-up-list' ARG, ignoring comments." + "Call `backward-up-list' ARG, ignoring comments and errors." (let ((parse-sexp-ignore-comments t)) - (backward-up-list arg))) + (condition-case nil + (backward-up-list arg) ;; May throw Unbalanced parenthesis + (error nil)))) (defun verilog-forward-sexp-cmt (arg) "Call `forward-sexp' ARG, inside comments." @@ -4595,13 +4629,15 @@ More specifically, after a generate and before an endgenerate." (while (and (/= nest 0) (verilog-re-search-backward - "\\<\\(module\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move) + "\\<\\(module\\)\\|\\(connectmodule\\)\\|\\(generate\\)\\|\\(endgenerate\\)\\>" nil 'move) (cond ((match-end 1) ; module - we have crawled out (throw 'done 1)) - ((match-end 2) ; generate + ((match-end 2) ; connectmodule - we have crawled out + (throw 'done 1)) + ((match-end 3) ; generate (setq nest (1- nest))) - ((match-end 3) ; endgenerate + ((match-end 4) ; endgenerate (setq nest (1+ nest)))))))) (= nest 0) )) ; return nest @@ -5064,6 +5100,8 @@ primitive or interface named NAME." (setq reg "\\(\\<clocking\\>\\)\\|\\<endclocking\\>")) ((match-end 16) ; of verilog-end-block-ordered-re (setq reg "\\(\\<property\\>\\)\\|\\<endproperty\\>")) + ((match-end 17) ; of verilog-end-block-ordered-re + (setq reg "\\(\\<connectmodule\\>\\)\\|\\<endconnectmodule\\>")) (t (error "Problem in verilog-set-auto-endcomments"))) (let (b e) @@ -5089,7 +5127,7 @@ primitive or interface named NAME." (setq string (buffer-substring b e))) (t (ding 't) - (setq string "unmatched end(function|task|module|primitive|interface|package|class|clocking)"))))) + (setq string "unmatched end(function|task|module|connectmodule|primitive|interface|package|class|clocking)"))))) (end-of-line) (insert (concat " // " string ))) )))))))))) @@ -5345,7 +5383,7 @@ becomes: (interactive) (save-excursion (beginning-of-line) - (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\):?.*$") + (when (looking-at "\\(.*\\)([WE]\\([0-9A-Z]+\\)).*,\\s +line\\s +[0-9]+:\\s +\\([^:\n]+\\).*$") (replace-match (format ;; %3s makes numbers 1-999 line up nicely "\\1//Verilint %3s off // WARNING: \\3" @@ -5560,7 +5598,7 @@ Return a list of two elements: (INDENT-TYPE INDENT-LEVEL)." (case-fold-search nil) (par 0) (begin (looking-at "[ \t]*begin\\>")) - (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)" nil t))) + (lim (save-excursion (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)" nil t))) (structres nil) (type (catch 'nesting ;; Keep working backwards until we can figure out @@ -6788,7 +6826,7 @@ Do not count named blocks or case-statements." ((looking-at verilog-named-block-re) (current-column)) ((and (not (looking-at verilog-extended-case-re)) - (looking-at "^[^:;]+[ \t]*:")) + (looking-at "^[^:;]+:")) (verilog-re-search-forward ":" nil t) (skip-chars-forward " \t") (current-column)) @@ -7113,7 +7151,7 @@ BASEIND is the base indent to offset everything." (let ((pos (point-marker)) (lim (save-excursion ;; (verilog-re-search-backward verilog-declaration-opener nil 'move) - (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<module\\>\\)\\|\\(\\<task\\>\\)" nil 'move) + (verilog-re-search-backward "\\(\\<begin\\>\\)\\|\\(\\<\\(connect\\)?module\\>\\)\\|\\(\\<task\\>\\)" nil 'move) (point))) (ind) (val) @@ -7272,7 +7310,7 @@ it displays a list of all possible completions.") \(integer, real, reg...)") (defvar verilog-cpp-keywords - '("module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else" + '("connectmodule" "module" "macromodule" "primitive" "timescale" "define" "ifdef" "ifndef" "else" "endif") "Keywords to complete when at first word of a line in declarative scope. \(initial, always, begin, assign...) @@ -7283,7 +7321,7 @@ will be completed at runtime and should not be added to this list.") (append '( "always" "always_comb" "always_ff" "always_latch" "assign" - "begin" "end" "generate" "endgenerate" "module" "endmodule" + "begin" "end" "connectmodule" "endconnectmodule" "generate" "endgenerate" "module" "endmodule" "specify" "endspecify" "function" "endfunction" "initial" "final" "task" "endtask" "primitive" "endprimitive" ) @@ -7380,9 +7418,9 @@ TYPE is `module', `tf' for task or function, or t if unknown." (if (string= verilog-str "") (setq verilog-str "[a-zA-Z_]")) (let ((verilog-str (concat (cond - ((eq type 'module) "\\<\\(module\\)\\s +") + ((eq type 'module) "\\<\\(module\\|connectmodule\\)\\s +") ((eq type 'tf) "\\<\\(task\\|function\\)\\s +") - (t "\\<\\(task\\|function\\|module\\)\\s +")) + (t "\\<\\(task\\|function\\|module\\|connectmodule\\)\\s +")) "\\<\\(" verilog-str "[a-zA-Z0-9_.]*\\)\\>")) match) @@ -7724,7 +7762,7 @@ If search fails, other files are checked based on (first 1) (prevpos (point-min)) (final-context-start (make-marker)) - (regexp "\\(module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)")) + (regexp "\\(\\(connect\\)?module\\s-+\\w+\\s-*(\\)\\|\\(\\w+\\s-+\\w+\\s-*(\\)")) (with-output-to-temp-buffer "*Occur*" (save-excursion (message "Searching for %s ..." regexp) @@ -7782,7 +7820,7 @@ If search fails, other files are checked based on "Return point if within translate-off region, else nil." (and (save-excursion (re-search-backward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "\\(on\\|off\\)\\>") + (concat "//.*" verilog-directive-regexp "\\(on\\|off\\)\\>") nil t)) (equal "off" (match-string 2)) (point))) @@ -7790,14 +7828,14 @@ If search fails, other files are checked based on (defun verilog-start-translate-off (limit) "Return point before translate-off directive if before LIMIT, else nil." (when (re-search-forward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>") + (concat "//.*" verilog-directive-regexp "off\\>") limit t) (match-beginning 0))) (defun verilog-back-to-start-translate-off (limit) "Return point before translate-off directive if before LIMIT, else nil." (when (re-search-backward - (concat "//\\s-*.*\\s-*" verilog-directive-regexp "off\\>") + (concat "//.*" verilog-directive-regexp "off\\>") limit t) (match-beginning 0))) @@ -7805,7 +7843,7 @@ If search fails, other files are checked based on "Return point after translate-on directive if before LIMIT, else nil." (re-search-forward (concat - "//\\s-*.*\\s-*" verilog-directive-regexp "on\\>") limit t)) + "//.*" verilog-directive-regexp "on\\>") limit t)) (defun verilog-match-translate-off (limit) "Match a translate-off block, setting `match-data' and returning t, else nil. @@ -8445,7 +8483,8 @@ Optional NUM-PARAM and MAX-PARAM check for a specific number of parameters." (let ((olist)) (save-excursion ;; /*AUTOPUNT("parameter", "parameter")*/ - (backward-sexp 1) + (when (not (eq (char-before) ?\*)) ; Not .* + (backward-sexp 1)) (while (looking-at "(?\\s *\"\\([^\"]*\\)\"\\s *,?") (setq olist (cons (match-string-no-properties 1) olist)) (goto-char (match-end 0)))) @@ -9895,7 +9934,7 @@ Allows version control to check out the file if need be." (while (and ;; It may be tempting to look for verilog-defun-re, ;; don't, it slows things down a lot! - (verilog-re-search-forward-quick "\\<\\(module\\|interface\\|program\\)\\>" nil t) + (verilog-re-search-forward-quick "\\<\\(connectmodule\\|module\\|interface\\|program\\)\\>" nil t) (setq type (match-string-no-properties 0)) (verilog-re-search-forward-quick "[(;]" nil t)) (if (equal module (verilog-read-module-name)) @@ -9982,7 +10021,7 @@ Or, just the existing dirnames themselves if there are no wildcards." (while dirnames (setq dirname (car dirnames) dirnames (cdr dirnames)) - (cond ((string-match (concat "^\\(\\|[/\\]*[^*?]*[/\\]\\)" ; root + (cond ((string-match (concat "^\\(\\|[^*?]*[/\\]\\)" ; root "\\([^/\\]*[*?][^/\\]*\\)" ; filename with *? "\\(.*\\)") ; rest dirname) @@ -10923,9 +10962,9 @@ shown) will make this into: ;; Presume one module per file. (save-excursion (goto-char (point-min)) - (while (verilog-re-search-forward-quick "\\<module\\>" nil t) + (while (verilog-re-search-forward-quick "\\<\\(connect\\)?module\\>" nil t) (let ((endmodp (save-excursion - (verilog-re-search-forward-quick "\\<endmodule\\>" nil t) + (verilog-re-search-forward-quick "\\<end\\(connect\\)?module\\>" nil t) (point)))) ;; See if there's already a comment .. inside a comment so not verilog-re-search (when (not (re-search-forward "/\\*AUTOARG\\*/" endmodp t)) @@ -11370,9 +11409,10 @@ See the example in `verilog-auto-inout-modport'." (defvar vl-bits nil "See `verilog-auto-inst'.") ; Prevent compile warning (defvar vl-mbits nil "See `verilog-auto-inst'.") ; Prevent compile warning -(defun verilog-auto-inst-port (port-st indent-pt moddecls tpl-list tpl-num for-star par-values) +(defun verilog-auto-inst-port (section port-st indent-pt moddecls tpl-list tpl-num + for-star par-values) "Print out an instantiation connection for this PORT-ST. -Insert to INDENT-PT, use template TPL-LIST. +Inside SECTION, insert to INDENT-PT, use template TPL-LIST. @ are instantiation numbers, replaced with TPL-NUM. @\"(expression @)\" are evaluated, with @ as a variable. If FOR-STAR add comment it is a .* expansion. @@ -11474,60 +11514,74 @@ If PAR-VALUES replace final strings with these parameter values." (setq tpl-net (verilog-string-replace-matches "\\[\\]\\[\\]" dflt-bits nil nil tpl-net)) (setq tpl-net (verilog-string-replace-matches "\\[\\]" vl-bits nil nil tpl-net))) ;; Insert it - (indent-to indent-pt) - (insert "." port) - (unless (and verilog-auto-inst-dot-name - (equal port tpl-net)) - (indent-to verilog-auto-inst-column) - (insert "(" tpl-net ")")) - (insert ",") - (cond (tpl-ass - (verilog-read-auto-template-hit tpl-ass) - (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) - verilog-auto-inst-column)) - ;; verilog-insert requires the complete comment in one call - including the newline - (cond ((equal verilog-auto-inst-template-numbers 'lhs) - (verilog-insert " // Templated" - " LHS: " (nth 0 tpl-ass) - "\n")) - (verilog-auto-inst-template-numbers - (verilog-insert " // Templated" - " T" (int-to-string (nth 2 tpl-ass)) - " L" (int-to-string (nth 3 tpl-ass)) - "\n")) - (t - (verilog-insert " // Templated\n")))) - (for-star - (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) - verilog-auto-inst-column)) - (verilog-insert " // Implicit .*\n")) - (t - (insert "\n"))))) -;;(verilog-auto-inst-port (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3") + (when (or tpl-ass (not verilog-auto-inst-template-required)) + (verilog-auto-inst-first section) + (indent-to indent-pt) + (insert "." port) + (unless (and verilog-auto-inst-dot-name + (equal port tpl-net)) + (indent-to verilog-auto-inst-column) + (insert "(" tpl-net ")")) + (insert ",") + (cond (tpl-ass + (verilog-read-auto-template-hit tpl-ass) + (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) + verilog-auto-inst-column)) + ;; verilog-insert requires the complete comment in one call - including the newline + (cond ((equal verilog-auto-inst-template-numbers 'lhs) + (verilog-insert " // Templated" + " LHS: " (nth 0 tpl-ass) + "\n")) + (verilog-auto-inst-template-numbers + (verilog-insert " // Templated" + " T" (int-to-string (nth 2 tpl-ass)) + " L" (int-to-string (nth 3 tpl-ass)) + "\n")) + (t + (verilog-insert " // Templated\n")))) + (for-star + (indent-to (+ (if (< verilog-auto-inst-column 48) 24 16) + verilog-auto-inst-column)) + (verilog-insert " // Implicit .*\n")) + (t + (insert "\n")))))) +;;(verilog-auto-inst-port "" (list "foo" "[5:0]") 10 (list (list "foo" "a@\"(% (+ @ 1) 4)\"a")) "3") ;;(x "incom[@\"(+ (* 8 @) 7)\":@\"(* 8 @)\"]") ;;(x ".out (outgo[@\"(concat (+ (* 8 @) 7) \\\":\\\" ( * 8 @))\"]));") -(defun verilog-auto-inst-port-list (sig-list indent-pt moddecls tpl-list tpl-num for-star par-values) - "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'." - (when verilog-auto-inst-sort - (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))) - (mapc (lambda (port) - (verilog-auto-inst-port port indent-pt moddecls - tpl-list tpl-num for-star par-values)) - sig-list)) +(defvar verilog-auto-inst-first-section nil + "Local first-in-section for `verilog-auto-inst-first'.") +(defvar verilog-auto-inst-first-any nil + "Local first-in-any-section for `verilog-auto-inst-first'.") -(defun verilog-auto-inst-first () - "Insert , etc before first ever port in this instant, as part of \\[verilog-auto-inst]." +(defun verilog-auto-inst-first (section) + "Insert , and SECTION before port, as part of \\[verilog-auto-inst]." ;; Do we need a trailing comma? ;; There maybe an ifdef or something similar before us. What a mess. Thus ;; to avoid trouble we only insert on preceding ) or *. ;; Insert first port on new line - (insert "\n") ; Must insert before search, so point will move forward if insert comma - (save-excursion - (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil) - (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure - (forward-char 1) - (insert ",")))) + (when verilog-auto-inst-first-any + (setq verilog-auto-inst-first-any nil) + (insert "\n") ; Must insert before search, so point will move forward if insert comma + (save-excursion + (verilog-re-search-backward-quick "[^ \t\n\f]" nil nil) + (when (looking-at ")\\|\\*") ; Generally don't insert, unless we are fairly sure + (forward-char 1) + (insert ",")))) + (when verilog-auto-inst-first-section + (setq verilog-auto-inst-first-section nil) + (verilog-insert-indent section))) + +(defun verilog-auto-inst-port-list (section sig-list indent-pt moddecls + tpl-list tpl-num for-star par-values) + "For `verilog-auto-inst' print a list of ports using `verilog-auto-inst-port'." + (when verilog-auto-inst-sort + (setq sig-list (sort (copy-alist sig-list) #'verilog-signals-sort-compare))) + (let ((verilog-auto-inst-first-section t)) + (mapc (lambda (port) + (verilog-auto-inst-port section port indent-pt moddecls + tpl-list tpl-num for-star par-values)) + sig-list))) (defun verilog-auto-star () "Expand SystemVerilog .* pins, as part of \\[verilog-auto]. @@ -11554,6 +11608,9 @@ Replace the pin connections to an instantiation or interface declaration with ones automatically derived from the module or interface header of the instantiated item. +You may also provide an optional regular expression, in which +case only I/O matching the regular expression will be included. + If `verilog-auto-star-expand' is set, also expand SystemVerilog .* ports, and delete them before saving unless `verilog-auto-star-save' is set. See `verilog-auto-star' for more information. @@ -11697,6 +11754,10 @@ Templates: debugging is completed though, it will result in lots of extra differences and merge conflicts. + If a connection name does not match any template, it is + connected to a net by the same name as the port (unless + `verilog-auto-inst-template-required' is true). + Setting `verilog-auto-template-warn-unused' will report errors if any template lines are unused. @@ -11868,16 +11929,19 @@ For more information see the \\[verilog-faq] and forums at URL `https://www.veripool.org'." (save-excursion ;; Find beginning - (let* ((pt (point)) + (let* ((params (verilog-read-auto-params 0 1)) + (regexp (nth 0 params)) + (pt (point)) (for-star (save-excursion (backward-char 2) (looking-at "\\.\\*"))) (indent-pt (save-excursion (verilog-backward-open-paren) (1+ (current-column)))) (verilog-auto-inst-column (max verilog-auto-inst-column (+ 16 (* 8 (/ (+ indent-pt 7) 8))))) + (verilog-auto-inst-first-any t) (modi (verilog-modi-current)) (moddecls (verilog-modi-get-decls modi)) submod submodi submoddecls - inst skip-pins tpl-list tpl-num did-first par-values) + inst skip-pins tpl-list tpl-num par-values) ;; Find module name that is instantiated (setq submod (verilog-read-inst-module) @@ -11912,53 +11976,58 @@ For more information see the \\[verilog-faq] and forums at URL (verilog-decls-get-vars submoddecls) skip-pins))) (vl-dir "interfaced")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when (and sig-list verilog-auto-inst-interfaced-ports) - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Interfaced\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Interfaced\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-interfaces submoddecls) skip-pins)) (vl-dir "interface")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Interfaces\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls - tpl-list tpl-num for-star par-values))) + (verilog-auto-inst-port-list "// Interfaces\n" + sig-list indent-pt moddecls + tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-outputs submoddecls) skip-pins)) (vl-dir "output")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Outputs\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Outputs\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-inouts submoddecls) skip-pins)) (vl-dir "inout")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Inouts\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Inouts\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) (let ((sig-list (verilog-signals-not-in (verilog-decls-get-inputs submoddecls) skip-pins)) (vl-dir "input")) + (when regexp + (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) - (verilog-insert-indent "// Inputs\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Inputs\n" + sig-list indent-pt moddecls tpl-list tpl-num for-star par-values))) ;; Kill extra semi (save-excursion - (cond (did-first + (cond ((not verilog-auto-inst-first-any) (re-search-backward "," pt t) (delete-char 1) (insert ");") @@ -12020,10 +12089,11 @@ Templates: (1+ (current-column)))) (verilog-auto-inst-column (max verilog-auto-inst-column (+ 16 (* 8 (/ (+ indent-pt 7) 8))))) + (verilog-auto-inst-first-any t) (modi (verilog-modi-current)) (moddecls (verilog-modi-get-decls modi)) submod submodi submoddecls - inst skip-pins tpl-list tpl-num did-first) + inst skip-pins tpl-list tpl-num) ;; Find module name that is instantiated (setq submod (save-excursion ;; Get to the point where AUTOINST normally is to read the module @@ -12060,14 +12130,13 @@ Templates: (when regexp (setq sig-list (verilog-signals-matching-regexp sig-list regexp))) (when sig-list - (when (not did-first) (verilog-auto-inst-first) (setq did-first t)) ;; Note these are searched for in verilog-read-sub-decls. - (verilog-insert-indent "// Parameters\n") - (verilog-auto-inst-port-list sig-list indent-pt moddecls + (verilog-auto-inst-port-list "// Parameters\n" + sig-list indent-pt moddecls tpl-list tpl-num nil nil))) ;; Kill extra semi (save-excursion - (cond (did-first + (cond ((not verilog-auto-inst-first-any) (re-search-backward "," pt t) (delete-char 1) (insert ")") diff --git a/lisp/progmodes/vhdl-mode.el b/lisp/progmodes/vhdl-mode.el index 39819131010..9cd84cf713b 100644 --- a/lisp/progmodes/vhdl-mode.el +++ b/lisp/progmodes/vhdl-mode.el @@ -16148,7 +16148,7 @@ expansion function)." ;; initialize speedbar (if (not (boundp 'speedbar-frame)) - (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize) + (with-no-warnings (add-hook 'speedbar-load-hook 'vhdl-speedbar-initialize)) (vhdl-speedbar-initialize) (when speedbar-frame (vhdl-speedbar-refresh))) diff --git a/lisp/progmodes/which-func.el b/lisp/progmodes/which-func.el index 1cee552b0c0..266f40abbae 100644 --- a/lisp/progmodes/which-func.el +++ b/lisp/progmodes/which-func.el @@ -186,7 +186,7 @@ and you want to simplify them for the mode line "Non-nil means display current function name in mode line. This makes a difference only if `which-function-mode' is non-nil.") -(add-hook 'find-file-hook 'which-func-ff-hook t) +(add-hook 'after-change-major-mode-hook 'which-func-ff-hook t) (defun which-func-try-to-enable () (unless (or (not which-function-mode) @@ -195,7 +195,7 @@ This makes a difference only if `which-function-mode' is non-nil.") (member major-mode which-func-modes))))) (defun which-func-ff-hook () - "File find hook for Which Function mode. + "`after-change-major-mode-hook' for Which Function mode. It creates the Imenu index for the buffer, if necessary." (which-func-try-to-enable) @@ -282,52 +282,55 @@ If no function name is found, return nil." (when (null name) (setq name (add-log-current-defun))) ;; If Imenu is loaded, try to make an index alist with it. + ;; If `add-log-current-defun' ran and gave nil, accept that. (when (and (null name) - (boundp 'imenu--index-alist) - (or (null imenu--index-alist) - ;; Update if outdated - (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) - (null which-function-imenu-failed)) - (ignore-errors (imenu--make-index-alist t)) - (unless imenu--index-alist - (set (make-local-variable 'which-function-imenu-failed) t))) - ;; If we have an index alist, use it. - (when (and (null name) - (boundp 'imenu--index-alist) imenu--index-alist) - (let ((alist imenu--index-alist) - (minoffset (point-max)) - offset pair mark imstack namestack) - ;; Elements of alist are either ("name" . marker), or - ;; ("submenu" ("name" . marker) ... ). The list can be - ;; arbitrarily nested. - (while (or alist imstack) - (if (null alist) - (setq alist (car imstack) - namestack (cdr namestack) - imstack (cdr imstack)) - - (setq pair (car-safe alist) - alist (cdr-safe alist)) - - (cond - ((atom pair)) ; Skip anything not a cons. - - ((imenu--subalist-p pair) - (setq imstack (cons alist imstack) - namestack (cons (car pair) namestack) - alist (cdr pair))) - - ((or (number-or-marker-p (setq mark (cdr pair))) - (and (overlayp mark) - (setq mark (overlay-start mark)))) - (when (and (>= (setq offset (- (point) mark)) 0) - (< offset minoffset)) ; Find the closest item. - (setq minoffset offset - name (if (null which-func-imenu-joiner-function) - (car pair) - (funcall - which-func-imenu-joiner-function - (reverse (cons (car pair) namestack)))))))))))) + (null add-log-current-defun-function)) + (when (and (null name) + (boundp 'imenu--index-alist) + (or (null imenu--index-alist) + ;; Update if outdated + (/= (buffer-chars-modified-tick) imenu-menubar-modified-tick)) + (null which-function-imenu-failed)) + (ignore-errors (imenu--make-index-alist t)) + (unless imenu--index-alist + (set (make-local-variable 'which-function-imenu-failed) t))) + ;; If we have an index alist, use it. + (when (and (null name) + (boundp 'imenu--index-alist) imenu--index-alist) + (let ((alist imenu--index-alist) + (minoffset (point-max)) + offset pair mark imstack namestack) + ;; Elements of alist are either ("name" . marker), or + ;; ("submenu" ("name" . marker) ... ). The list can be + ;; arbitrarily nested. + (while (or alist imstack) + (if (null alist) + (setq alist (car imstack) + namestack (cdr namestack) + imstack (cdr imstack)) + + (setq pair (car-safe alist) + alist (cdr-safe alist)) + + (cond + ((atom pair)) ; Skip anything not a cons. + + ((imenu--subalist-p pair) + (setq imstack (cons alist imstack) + namestack (cons (car pair) namestack) + alist (cdr pair))) + + ((or (number-or-marker-p (setq mark (cdr pair))) + (and (overlayp mark) + (setq mark (overlay-start mark)))) + (when (and (>= (setq offset (- (point) mark)) 0) + (< offset minoffset)) ; Find the closest item. + (setq minoffset offset + name (if (null which-func-imenu-joiner-function) + (car pair) + (funcall + which-func-imenu-joiner-function + (reverse (cons (car pair) namestack))))))))))))) ;; Filter the name if requested. (when name (if which-func-cleanup-function diff --git a/lisp/progmodes/xref.el b/lisp/progmodes/xref.el index c36a9bd9940..3e3a37f6da5 100644 --- a/lisp/progmodes/xref.el +++ b/lisp/progmodes/xref.el @@ -1,6 +1,11 @@ -;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- +;;; xref.el --- Cross-referencing commands -*-lexical-binding:t-*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. +;; Version: 1.0.1 +;; Package-Requires: ((emacs "26.3") (project "0.1.1")) + +;; This is a GNU ELPA :core package. Avoid functionality that is not +;; compatible with the version of Emacs recorded above. ;; This file is part of GNU Emacs. @@ -259,16 +264,20 @@ be found, return nil. The default implementation uses `semantic-symref-tool-alist' to find a search tool; by default, this uses \"find | grep\" in the `project-current' roots." - (cl-mapcan + (mapcan (lambda (dir) (xref-references-in-directory identifier dir)) (let ((pr (project-current t))) - (append - (project-roots pr) + (cons + (project-root pr) (project-external-roots pr))))) (cl-defgeneric xref-backend-apropos (backend pattern) - "Find all symbols that match regexp PATTERN.") + "Find all symbols that match PATTERN string. +The second argument has the same meaning as in `apropos'. + +If BACKEND is implemented in Lisp, it can use +`xref-apropos-regexp' to convert the pattern to regexp.") (cl-defgeneric xref-backend-identifier-at-point (_backend) "Return the relevant identifier at point. @@ -1093,14 +1102,24 @@ The argument has the same meaning as in `apropos'." "Search for pattern (word list or regexp): " nil 'xref--read-pattern-history))) (require 'apropos) - (xref--find-xrefs pattern 'apropos - (apropos-parse-pattern - (if (string-equal (regexp-quote pattern) pattern) - ;; Split into words - (or (split-string pattern "[ \t]+" t) - (user-error "No word list given")) - pattern)) - nil)) + (let* ((newpat + (if (and (version< emacs-version "28.0.50") + (memq (xref-find-backend) '(elisp etags))) + ;; Handle backends in older Emacs. + (xref-apropos-regexp pattern) + ;; Delegate pattern handling to the backend fully. + ;; The old way didn't work for "external" backends. + pattern))) + (xref--find-xrefs pattern 'apropos newpat nil))) + +(defun xref-apropos-regexp (pattern) + "Return an Emacs regexp from PATTERN similar to `apropos'." + (apropos-parse-pattern + (if (string-equal (regexp-quote pattern) pattern) + ;; Split into words + (or (split-string pattern "[ \t]+" t) + (user-error "No word list given")) + pattern))) ;;; Key bindings @@ -1317,11 +1336,11 @@ directory, used as the root of the ignore globs." (lambda (ignore) (when (string-match-p "/\\'" ignore) (setq ignore (concat ignore "*"))) - (if (string-match "\\`\\./" ignore) - (setq ignore (replace-match dir t t ignore)) - (unless (string-prefix-p "*" ignore) - (setq ignore (concat "*/" ignore)))) - (shell-quote-argument ignore)) + (shell-quote-argument (if (string-match "\\`\\./" ignore) + (replace-match dir t t ignore) + (if (string-prefix-p "*" ignore) + ignore + (concat "*/" ignore))))) ignores " -o -path ") " " @@ -1364,8 +1383,8 @@ Such as the current syntax table and the applied syntax properties." (let (xref--last-file-buffer (tmp-buffer (generate-new-buffer " *xref-temp*"))) (unwind-protect - (cl-mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) - hits) + (mapcan (lambda (hit) (xref--collect-matches hit regexp tmp-buffer)) + hits) (kill-buffer tmp-buffer)))) (defun xref--collect-matches (hit regexp tmp-buffer) diff --git a/lisp/recentf.el b/lisp/recentf.el index b636e594864..27918a9739c 100644 --- a/lisp/recentf.el +++ b/lisp/recentf.el @@ -277,6 +277,8 @@ If `file-name-history' is not empty, do nothing." "Normal hook run at end of loading the `recentf' package." :group 'recentf :type 'hook) +(make-obsolete-variable 'recentf-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom recentf-filename-handlers nil "Functions to post process recent file names. diff --git a/lisp/registry.el b/lisp/registry.el index 7d95d91ad2c..ef47f07aec5 100644 --- a/lisp/registry.el +++ b/lisp/registry.el @@ -317,7 +317,7 @@ Errors out if the key exists already." (message "reindexing: %d of %d (%.2f%%)" count expected (/ (* 100.0 count) expected))) (dolist (val (cdr-safe (assq tr v))) - (let* ((value-keys (registry-lookup-secondary-value db tr val))) + (let ((value-keys (registry-lookup-secondary-value db tr val))) (push key value-keys) (registry-lookup-secondary-value db tr val value-keys)))) (oref db data)))))) diff --git a/lisp/repeat.el b/lisp/repeat.el index db33b083386..f275db6fddf 100644 --- a/lisp/repeat.el +++ b/lisp/repeat.el @@ -4,7 +4,7 @@ ;; Author: Will Mengarini <seldon@eskimo.com> ;; Created: Mo 02 Mar 98 -;; Version: 0.51 +;; Old-Version: 0.51 ;; Keywords: convenience, vi, repeat ;; This file is part of GNU Emacs. diff --git a/lisp/replace.el b/lisp/replace.el index 0880cbdb1ea..69092c16f96 100644 --- a/lisp/replace.el +++ b/lisp/replace.el @@ -757,6 +757,13 @@ which will run faster and will not set the mark or print anything." Maximum length of the history list is determined by the value of `history-length', which see.") +(defvar occur-highlight-regexp t + "Regexp matching part of visited source lines to highlight temporarily. +Highlight entire line if t; don't highlight source lines if nil.") + +(defvar occur-highlight-overlay nil + "Overlay used to temporarily highlight occur matches.") + (defvar occur-collect-regexp-history '("\\1") "History of regexp for occur's collect operation") @@ -1113,6 +1120,8 @@ a previously found match." (define-key map "\C-m" 'occur-mode-goto-occurrence) (define-key map "o" 'occur-mode-goto-occurrence-other-window) (define-key map "\C-o" 'occur-mode-display-occurrence) + (define-key map "n" 'next-error-no-select) + (define-key map "p" 'previous-error-no-select) (define-key map "\M-n" 'occur-next) (define-key map "\M-p" 'occur-prev) (define-key map "r" 'occur-rename-buffer) @@ -1261,9 +1270,12 @@ If not invoked by a mouse click, go to occurrence on the current line." (with-current-buffer (window-buffer (posn-window (event-end event))) (save-excursion (goto-char (posn-point (event-end event))) - (occur-mode-find-occurrence)))))) + (occur-mode-find-occurrence))))) + (regexp occur-highlight-regexp)) (pop-to-buffer (marker-buffer pos)) (goto-char pos) + (let ((end-mk (save-excursion (re-search-forward regexp nil t)))) + (occur--highlight-occurrence pos end-mk)) (when buffer (next-error-found buffer (current-buffer))) (run-hooks 'occur-mode-find-occurrence-hook))) @@ -1277,17 +1289,74 @@ If not invoked by a mouse click, go to occurrence on the current line." (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook))) +;; Stolen from compile.el +(defun occur-goto-locus-delete-o () + (delete-overlay occur-highlight-overlay) + ;; Get rid of timer and hook that would try to do this again. + (if (timerp next-error-highlight-timer) + (cancel-timer next-error-highlight-timer)) + (remove-hook 'pre-command-hook + #'occur-goto-locus-delete-o)) + +;; Highlight the current visited occurrence. +;; Adapted from `compilation-goto-locus'. +(defun occur--highlight-occurrence (mk end-mk) + (let ((highlight-regexp occur-highlight-regexp)) + (if (timerp next-error-highlight-timer) + (cancel-timer next-error-highlight-timer)) + (unless occur-highlight-overlay + (setq occur-highlight-overlay + (make-overlay (point-min) (point-min))) + (overlay-put occur-highlight-overlay 'face 'next-error)) + (with-current-buffer (marker-buffer mk) + (save-excursion + (if end-mk (goto-char end-mk) (end-of-line)) + (let ((end (point))) + (if mk (goto-char mk) (beginning-of-line)) + (if (and (stringp highlight-regexp) + (re-search-forward highlight-regexp end t)) + (progn + (goto-char (match-beginning 0)) + (move-overlay occur-highlight-overlay + (match-beginning 0) (match-end 0) + (current-buffer))) + (move-overlay occur-highlight-overlay + (point) end (current-buffer))) + (if (or (eq next-error-highlight t) + (numberp next-error-highlight)) + ;; We want highlighting: delete overlay on next input. + (add-hook 'pre-command-hook + #'occur-goto-locus-delete-o) + ;; We don't want highlighting: delete overlay now. + (delete-overlay occur-highlight-overlay)) + ;; We want highlighting for a limited time: + ;; set up a timer to delete it. + (when (numberp next-error-highlight) + (setq next-error-highlight-timer + (run-at-time next-error-highlight nil + 'occur-goto-locus-delete-o)))))) + (when (eq next-error-highlight 'fringe-arrow) + ;; We want a fringe arrow (instead of highlighting). + (setq next-error-overlay-arrow-position + (copy-marker (line-beginning-position)))))) + (defun occur-mode-display-occurrence () "Display in another window the occurrence the current line describes." (interactive) (let ((buffer (current-buffer)) (pos (occur-mode-find-occurrence)) + (regexp occur-highlight-regexp) + (next-error-highlight next-error-highlight-no-select) + (display-buffer-overriding-action + '(nil (inhibit-same-window . t))) window) (setq window (display-buffer (marker-buffer pos) t)) ;; This is the way to set point in the proper window. (save-selected-window (select-window window) (goto-char pos) + (let ((end-mk (save-excursion (re-search-forward regexp nil t)))) + (occur--highlight-occurrence pos end-mk)) (next-error-found buffer (current-buffer)) (run-hooks 'occur-mode-find-occurrence-hook)))) @@ -1583,7 +1652,8 @@ See also `multi-occur'." (and (overlayp boo) (overlay-buffer boo))) boo)) - bufs)))) + bufs))) + (source-buffer-default-directory default-directory)) ;; Handle the case where one of the buffers we're searching is the ;; output buffer. Just rename it. (when (member buf-name @@ -1600,6 +1670,9 @@ See also `multi-occur'." (setq occur-buf (get-buffer-create buf-name)) (with-current-buffer occur-buf + ;; Make the default-directory of the *Occur* buffer match that of + ;; the buffer where the occurences come from + (setq default-directory source-buffer-default-directory) (if (stringp nlines) (fundamental-mode) ;; This is for collect operation. (occur-mode)) @@ -1608,6 +1681,7 @@ See also `multi-occur'." (buffer-undo-list t) (occur--final-pos nil)) (erase-buffer) + (set (make-local-variable 'occur-highlight-regexp) regexp) (let ((count (if (stringp nlines) ;; Treat nlines as a regexp to collect. @@ -1944,10 +2018,8 @@ See also `multi-occur'." global-matches))) (defun occur-engine-line (beg end &optional keep-props) - (if (and keep-props (if (boundp 'jit-lock-mode) jit-lock-mode) - (text-property-not-all beg end 'fontified t)) - (if (fboundp 'jit-lock-fontify-now) - (jit-lock-fontify-now beg end))) + (if (and keep-props font-lock-mode) + (font-lock-ensure beg end)) (if (and keep-props (not (eq occur-excluded-properties t))) (let ((str (buffer-substring beg end))) (remove-list-of-text-properties diff --git a/lisp/ruler-mode.el b/lisp/ruler-mode.el index f6b49b46e3f..82e6178da14 100644 --- a/lisp/ruler-mode.el +++ b/lisp/ruler-mode.el @@ -4,7 +4,7 @@ ;; Author: David Ponce <david@dponce.com> ;; Created: 24 Mar 2001 -;; Version: 1.6 +;; Old-Version: 1.6 ;; Keywords: convenience ;; This file is part of GNU Emacs. diff --git a/lisp/saveplace.el b/lisp/saveplace.el index fa0e181bb10..46738ab03dc 100644 --- a/lisp/saveplace.el +++ b/lisp/saveplace.el @@ -248,8 +248,8 @@ may have changed) back to `save-place-alist'." (delete-region (point-min) (point-max)) (when save-place-forget-unreadable-files (save-place-forget-unreadable-files)) - (insert (format ";;; -*- coding: %s -*-\n" - (symbol-name coding-system-for-write))) + (insert (format ";;; -*- coding: %s; mode: lisp-data -*-\n" + coding-system-for-write)) (let ((print-length nil) (print-level nil)) (pp save-place-alist (current-buffer))) diff --git a/lisp/sb-image.el b/lisp/sb-image.el deleted file mode 100644 index 1e8b1057bc8..00000000000 --- a/lisp/sb-image.el +++ /dev/null @@ -1,107 +0,0 @@ -;;; sb-image --- Image management for speedbar - -;; Copyright (C) 1999-2003, 2005-2020 Free Software Foundation, Inc. - -;; Author: Eric M. Ludlam <zappo@gnu.org> -;; Keywords: file, tags, tools - -;; This file is part of GNU Emacs. - -;; GNU Emacs is free software: you can redistribute it and/or modify -;; it under the terms of the GNU General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. - -;; GNU Emacs is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -;; GNU General Public License for more details. - -;; You should have received a copy of the GNU General Public License -;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. - -;;; Commentary: -;; -;; Supporting Image display for Emacs 20 and less, Emacs 21, and XEmacs, -;; is a challenging task, which doesn't take kindly to being byte compiled. -;; When sharing speedbar.elc between these three applications, the Image -;; support can get lost. -;; -;; By splitting out that hard part into this file, and avoiding byte -;; compilation, one copy speedbar can support all these platforms together. -;; -;; This file requires the `image' package if it is available. - -(require 'ezimage) - -;;; Code: -(defcustom speedbar-use-images ezimage-use-images - "Non-nil if speedbar should display icons." - :group 'speedbar - :version "21.1" - :type 'boolean) - -(defalias 'defimage-speedbar 'defezimage) - -(defvar speedbar-expand-image-button-alist - '(("<+>" . ezimage-directory-plus) - ("<->" . ezimage-directory-minus) - ("< >" . ezimage-directory) - ("[+]" . ezimage-page-plus) - ("[-]" . ezimage-page-minus) - ("[?]" . ezimage-page) - ("[ ]" . ezimage-page) - ("{+}" . ezimage-box-plus) - ("{-}" . ezimage-box-minus) - ("<M>" . ezimage-mail) - ("<d>" . ezimage-document-tag) - ("<i>" . ezimage-info-tag) - (" =>" . ezimage-tag) - (" +>" . ezimage-tag-gt) - (" ->" . ezimage-tag-v) - (">" . ezimage-tag) - ("@" . ezimage-tag-type) - (" @" . ezimage-tag-type) - ("*" . ezimage-checkout) - ("#" . ezimage-object) - ("!" . ezimage-object-out-of-date) - ("//" . ezimage-label) - ("%" . ezimage-lock) - ) - "List of text and image associations.") - -(defun speedbar-insert-image-button-maybe (start length) - "Insert an image button based on text starting at START for LENGTH chars. -If buttontext is unknown, just insert that text. -If we have an image associated with it, use that image." - (when speedbar-use-images - (let ((ezimage-expand-image-button-alist - speedbar-expand-image-button-alist)) - (ezimage-insert-image-button-maybe start length)))) - -(defun speedbar-image-dump () - "Dump out the current state of the Speedbar image alist. -See `speedbar-expand-image-button-alist' for details." - (interactive) - (with-output-to-temp-buffer "*Speedbar Images*" - (with-current-buffer "*Speedbar Images*" - (goto-char (point-max)) - (insert "Speedbar image cache.\n\n") - (let ((start (point)) (end nil)) - (insert "Image\tText\tImage Name") - (setq end (point)) - (insert "\n") - (put-text-property start end 'face 'underline)) - (let ((ia speedbar-expand-image-button-alist)) - (while ia - (let ((start (point))) - (insert (car (car ia))) - (insert "\t") - (speedbar-insert-image-button-maybe start - (length (car (car ia)))) - (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n")) - (setq ia (cdr ia))))))) - -(provide 'sb-image) - -;;; sb-image.el ends here diff --git a/lisp/server.el b/lisp/server.el index e6d8b1783c9..18612181477 100644 --- a/lisp/server.el +++ b/lisp/server.el @@ -563,7 +563,7 @@ See variable `server-auth-dir' for details." (format "it is not owned by you (owner = %s (%d))" (user-full-name uid) uid)) (w32 nil) ; on NTFS? - ((let ((modes (file-modes dir))) + ((let ((modes (file-modes dir 'nofollow))) (unless (zerop (logand (or modes 0) #o077)) (format "it is accessible by others (%03o)" modes)))) (t nil)))) diff --git a/lisp/shell.el b/lisp/shell.el index dc1198b7bac..dc528412a62 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -249,7 +249,7 @@ This mirrors the optional behavior of tcsh." (defcustom shell-chdrive-regexp (if (memq system-type '(ms-dos windows-nt)) ; NetWare allows the five chars between upper and lower alphabetics. - "[]a-zA-Z^_`\\[\\\\]:" + "[]a-zA-Z^_`[\\]:" nil) "If non-nil, is regexp used to track drive changes." :type '(choice regexp @@ -374,7 +374,7 @@ Thus, this does not include the shell's current directory.") "\\|\\$\\(?:\\([[:alpha:]][[:alnum:]]*\\)" "\\|{\\(?1:[^{}]+\\)}\\)" (when (memq system-type '(ms-dos windows-nt)) - "\\|%\\(?1:[^\\\\/]*\\)%") + "\\|%\\(?1:[^\\/]*\\)%") (when comint-file-name-quote-list "\\|\\\\\\(.\\)"))) (qupos nil) diff --git a/lisp/simple.el b/lisp/simple.el index e4958de113e..2f92238e640 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -199,7 +199,7 @@ rejected, and the function returns nil." (and extra-test-inclusive (funcall extra-test-inclusive)))))) -(defcustom next-error-find-buffer-function #'next-error-buffer-unnavigated-current +(defcustom next-error-find-buffer-function #'ignore "Function called to find a `next-error' capable buffer. This functions takes the same three arguments as the function `next-error-find-buffer', and should return the buffer to be @@ -215,7 +215,7 @@ all other buffers." next-error-buffer-unnavigated-current) (function :tag "Other function")) :group 'next-error - :version "27.1") + :version "28.1") (defcustom next-error-found-function #'ignore "Function called when a next locus is found and displayed. @@ -1227,6 +1227,10 @@ that uses or sets the mark." ;; Counting lines, one way or another. +(defvar goto-line-history nil + "History of values entered with `goto-line'.") +(make-variable-buffer-local 'goto-line-history) + (defun goto-line (line &optional buffer) "Go to LINE, counting from line 1 at beginning of buffer. If called interactively, a numeric prefix argument specifies @@ -1271,7 +1275,8 @@ rather than line counts." ""))) ;; Read the argument, offering that number (if any) as default. (list (read-number (format "Goto line%s: " buffer-prompt) - (list default (line-number-at-pos))) + (list default (line-number-at-pos)) + 'goto-line-history) buffer)))) ;; Switch to the desired buffer, one way or another. (if buffer @@ -1617,8 +1622,11 @@ display the result of expression evaluation." (let ((minibuffer-completing-symbol t)) (minibuffer-with-setup-hook (lambda () - ;; FIXME: call emacs-lisp-mode (see also - ;; `eldoc--eval-expression-setup')? + ;; FIXME: instead of just applying the syntax table, maybe + ;; use a special major mode tailored to reading Lisp + ;; expressions from the minibuffer? (`emacs-lisp-mode' + ;; doesn't preserve the necessary keybindings.) + (set-syntax-table emacs-lisp-mode-syntax-table) (add-hook 'completion-at-point-functions #'elisp-completion-at-point nil t) (run-hooks 'eval-expression-minibuffer-setup-hook)) @@ -1797,23 +1805,36 @@ to get different commands to edit and resubmit." ;; and it serves as a shorthand for "Extended command: ". "M-x ") (lambda (string pred action) - (let ((pred - (if (memq action '(nil t)) - ;; Exclude obsolete commands from completions. - (lambda (sym) - (and (funcall pred sym) - (or (equal string (symbol-name sym)) - (not (get sym 'byte-obsolete-info))))) - pred))) - (complete-with-action action obarray string pred))) + (if (and suggest-key-bindings (eq action 'metadata)) + '(metadata + (annotation-function . read-extended-command--annotation) + (category . command)) + (let ((pred + (if (memq action '(nil t)) + ;; Exclude obsolete commands from completions. + (lambda (sym) + (and (funcall pred sym) + (or (equal string (symbol-name sym)) + (not (get sym 'byte-obsolete-info))))) + pred))) + (complete-with-action action obarray string pred)))) #'commandp t nil 'extended-command-history))) +(defun read-extended-command--annotation (command-name) + (let* ((function (and (stringp command-name) (intern-soft command-name))) + (binding (where-is-internal function overriding-local-map t))) + (when (and binding (not (stringp binding))) + (format " (%s)" (key-description binding))))) + (defcustom suggest-key-bindings t "Non-nil means show the equivalent key-binding when M-x command has one. The value can be a length of time to show the message for. If the value is non-nil and not a number, we wait 2 seconds. -Also see `extended-command-suggest-shorter'." +Also see `extended-command-suggest-shorter'. + +Equivalent key-bindings are also shown in the completion list of +M-x for all commands that have them." :group 'keyboard :type '(choice (const :tag "off" nil) (integer :tag "time" 2) @@ -2528,6 +2549,11 @@ A redo record for ordinary undo maps to the following (earlier) undo.") "Within a run of consecutive undo commands, list remaining to be undone. If t, we undid all the way to the end of it.") +(defun undo--last-change-was-undo-p (undo-list) + (while (and (consp undo-list) (eq (car undo-list) nil)) + (setq undo-list (cdr undo-list))) + (gethash undo-list undo-equiv-table)) + (defun undo (&optional arg) "Undo some previous changes. Repeat this command to undo more changes. @@ -2563,12 +2589,7 @@ as an argument limits undo to changes within the current region." (or (eq pending-undo-list t) ;; If something (a timer or filter?) changed the buffer ;; since the previous command, don't continue the undo seq. - (let ((list buffer-undo-list)) - (while (eq (car list) nil) - (setq list (cdr list))) - ;; If the last undo record made was made by undo - ;; it shows nothing else happened in between. - (gethash list undo-equiv-table)))) + (undo--last-change-was-undo-p buffer-undo-list))) (setq undo-in-region (and (or (region-active-p) (and arg (not (numberp arg)))) (not inhibit-region))) @@ -2658,6 +2679,25 @@ Contrary to `undo', this will not redo a previous undo." (interactive "*p") (let ((undo-no-redo t)) (undo arg))) +(defun undo-redo (&optional arg) + "Undo the last ARG undos." + (interactive "*p") + (cond + ((not (undo--last-change-was-undo-p buffer-undo-list)) + (user-error "No undo to undo")) + (t + (let* ((ul buffer-undo-list) + (new-ul + (let ((undo-in-progress t)) + (while (and (consp ul) (eq (car ul) nil)) + (setq ul (cdr ul))) + (primitive-undo arg ul))) + (new-pul (undo--last-change-was-undo-p new-ul))) + (message "Redo%s" (if undo-in-region " in region" "")) + (setq this-command 'undo) + (setq pending-undo-list new-pul) + (setq buffer-undo-list new-ul))))) + (defvar undo-in-progress nil "Non-nil while performing an undo. Some change-hooks test this variable to do something different.") @@ -3945,7 +3985,7 @@ characters." exit-status) ;; Unless a single contiguous chunk is selected, operate on multiple chunks. (if region-noncontiguous-p - (let ((input (concat (funcall region-extract-function 'delete) "\n")) + (let ((input (concat (funcall region-extract-function (when replace 'delete)) "\n")) output) (with-temp-buffer (insert input) @@ -3953,9 +3993,24 @@ characters." shell-file-name t t nil shell-command-switch command) - (setq output (split-string (buffer-string) "\n"))) - (goto-char start) - (funcall region-insert-function output)) + (setq output (split-string (buffer-substring + (point-min) + ;; Trim the trailing newline. + (if (eq (char-before (point-max)) ?\n) + (1- (point-max)) + (point-max))) + "\n"))) + (cond + (replace + (goto-char start) + (funcall region-insert-function output)) + (t + (let ((buffer (get-buffer-create + (or output-buffer "*Shell Command Output*")))) + (with-current-buffer buffer + (erase-buffer) + (funcall region-insert-function output)) + (display-message-or-buffer buffer))))) (if (or replace (and output-buffer (not (or (bufferp output-buffer) (stringp output-buffer))))) @@ -4118,6 +4173,20 @@ its behavior with respect to remote file attribute caching. You should only ever change this variable with a let-binding; never with `setq'.") +(defcustom process-file-return-signal-string nil + "Whether to return a string describing the signal interrupting a process. +When a process returns an exit code greater than 128, it is +interpreted as a signal. `process-file' requires to return a +string describing this signal. +Since there are processes violating this rule, returning exit +codes greater than 128 which are not bound to a signal, +`process-file' returns the exit code as natural number also in +this case. Setting this user option to non-nil forces +`process-file' to interpret such exit codes as signals, and to +return a corresponding string." + :version "28.1" + :type 'boolean) + (defun start-file-process (name buffer program &rest program-args) "Start a program in a subprocess. Return the process object for it. diff --git a/lisp/so-long.el b/lisp/so-long.el index dcf7e62ca74..6b05f4821b1 100644 --- a/lisp/so-long.el +++ b/lisp/so-long.el @@ -353,7 +353,7 @@ ;; this caveat is the `mode' pseudo-variable, which is processed early in all ;; versions of Emacs, and can be set to `so-long-mode' if desired. -;;; * Change Log: +;; * Change Log: ;; ;; 1.0 - Included in Emacs 27.1, and in GNU ELPA for prior versions of Emacs. ;; - New global mode `global-so-long-mode' to enable/disable the library. @@ -944,8 +944,10 @@ This command calls `so-long' with the selected action as an argument.") (cl-letf (((symbol-function 'finder-summary) #'ignore)) (finder-commentary "so-long")) (let ((inhibit-read-only t)) - (when (looking-at "^Commentary:\n\n") - (replace-match "so-long.el\n\n")) + (if (looking-at "^Commentary:\n\n") + (replace-match "so-long.el\n\n") + (insert "so-long.el\n") + (forward-line 1)) (save-excursion (while (re-search-forward "^-+$" nil :noerror) (replace-match "")))) diff --git a/lisp/speedbar.el b/lisp/speedbar.el index 4cd4fb9161d..e9c15b71ce6 100644 --- a/lisp/speedbar.el +++ b/lisp/speedbar.el @@ -7,10 +7,12 @@ (defvar speedbar-version "1.0" "The current version of speedbar.") +(make-obsolete-variable 'speedbar-version nil "28.1") (defvar speedbar-incompatible-version "0.14beta4" "This version of speedbar is incompatible with this version. Due to massive API changes (removing the use of the word PATH) this version is not backward compatible to 0.14 or earlier.") +(make-obsolete-variable 'speedbar-incompatible-version nil "28.1") ;; This file is part of GNU Emacs. @@ -115,7 +117,7 @@ this version is not backward compatible to 0.14 or earlier.") (require 'easymenu) (require 'dframe) -(require 'sb-image) +(require 'ezimage) ;; customization stuff (defgroup speedbar nil @@ -141,6 +143,12 @@ this version is not backward compatible to 0.14 or earlier.") :prefix "speedbar-" :group 'speedbar) +(defcustom speedbar-use-images ezimage-use-images + "Non-nil if speedbar should display icons." + :group 'speedbar + :version "21.1" + :type 'boolean) + ;;; Code: ;; Note: `inversion-test' requires parts of the CEDET package that are @@ -296,6 +304,8 @@ The default buffer is the buffer in the selected window in the attached frame." "Hooks run when speedbar is loaded." :group 'speedbar :type 'hook) +(make-obsolete-variable 'speedbar-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom speedbar-reconfigure-keymaps-hook nil "Hooks run when the keymaps are regenerated." @@ -641,7 +651,7 @@ They should include commonly existing directories which are not useful. It is no longer necessary to include version-control directories here; see `vc-directory-exclusion-list'." :group 'speedbar - :type 'string) + :type 'regexp) (defcustom speedbar-file-unshown-regexp (let ((nstr "") (noext completion-ignored-extensions)) @@ -654,7 +664,7 @@ directories here; see `vc-directory-exclusion-list'." "Regexp matching files we don't want displayed in a speedbar buffer. It is generated from the variable `completion-ignored-extensions'." :group 'speedbar - :type 'string) + :type 'regexp) (defvar speedbar-file-regexp nil "Regular expression matching files we know how to expand. @@ -1069,7 +1079,7 @@ in the selected file. (setq font-lock-keywords nil) ;; no font-locking please (setq truncate-lines t) (make-local-variable 'frame-title-format) - (setq frame-title-format (concat "Speedbar " speedbar-version) + (setq frame-title-format "Speedbar" case-fold-search nil buffer-read-only t) (speedbar-set-mode-line-format) @@ -1703,7 +1713,7 @@ argument." (put-text-property start end 'help-echo #'dframe-help-echo)) (if function (put-text-property start end 'speedbar-function function)) (if token (put-text-property start end 'speedbar-token token)) - ;; So far the only text we have is less that 3 chars. + ;; So far the only text we have is less than 3 chars. (if (<= (- end start) 3) (speedbar-insert-image-button-maybe start (- end start))) ) @@ -4022,6 +4032,68 @@ TEXT is the buffer's name, TOKEN and INDENT are unused." (setq font-lock-global-modes (delq 'speedbar-mode font-lock-global-modes))))) +;;; Image management + +(defvar speedbar-expand-image-button-alist + '(("<+>" . ezimage-directory-plus) + ("<->" . ezimage-directory-minus) + ("< >" . ezimage-directory) + ("[+]" . ezimage-page-plus) + ("[-]" . ezimage-page-minus) + ("[?]" . ezimage-page) + ("[ ]" . ezimage-page) + ("{+}" . ezimage-box-plus) + ("{-}" . ezimage-box-minus) + ("<M>" . ezimage-mail) + ("<d>" . ezimage-document-tag) + ("<i>" . ezimage-info-tag) + (" =>" . ezimage-tag) + (" +>" . ezimage-tag-gt) + (" ->" . ezimage-tag-v) + (">" . ezimage-tag) + ("@" . ezimage-tag-type) + (" @" . ezimage-tag-type) + ("*" . ezimage-checkout) + ("#" . ezimage-object) + ("!" . ezimage-object-out-of-date) + ("//" . ezimage-label) + ("%" . ezimage-lock) + ) + "List of text and image associations.") + +(defun speedbar-insert-image-button-maybe (start length) + "Insert an image button based on text starting at START for LENGTH chars. +If buttontext is unknown, just insert that text. +If we have an image associated with it, use that image." + (when speedbar-use-images + (let ((ezimage-expand-image-button-alist + speedbar-expand-image-button-alist)) + (ezimage-insert-image-button-maybe start length)))) + +(defun speedbar-image-dump () + "Dump out the current state of the Speedbar image alist. +See `speedbar-expand-image-button-alist' for details." + (interactive) + (with-output-to-temp-buffer "*Speedbar Images*" + (with-current-buffer "*Speedbar Images*" + (goto-char (point-max)) + (insert "Speedbar image cache.\n\n") + (let ((start (point)) (end nil)) + (insert "Image\tText\tImage Name") + (setq end (point)) + (insert "\n") + (put-text-property start end 'face 'underline)) + (let ((ia speedbar-expand-image-button-alist)) + (while ia + (let ((start (point))) + (insert (car (car ia))) + (insert "\t") + (speedbar-insert-image-button-maybe start + (length (car (car ia)))) + (insert (car (car ia)) "\t" (format "%s" (cdr (car ia))) "\n")) + (setq ia (cdr ia))))))) + + (provide 'speedbar) ;; run load-time hooks diff --git a/lisp/strokes.el b/lisp/strokes.el index 7a88744540b..08a381801d7 100644 --- a/lisp/strokes.el +++ b/lisp/strokes.el @@ -296,6 +296,8 @@ the corresponding interactive function.") (defvar strokes-load-hook nil "Functions to be called when Strokes is loaded.") +(make-obsolete-variable 'strokes-load-hook + "use `with-eval-after-load' instead." "28.1") ;;; ### NOT IMPLEMENTED YET ### ;;(defvar edit-strokes-menu @@ -1373,9 +1375,7 @@ If STROKES-MAP is not given, `strokes-global-map' will be used instead." (defun strokes-alphabetic-lessp (stroke1 stroke2) "Return t if STROKE1's command name precedes STROKE2's in lexicographic order." - (let ((command-name-1 (symbol-name (cdr stroke1))) - (command-name-2 (symbol-name (cdr stroke2)))) - (string-lessp command-name-1 command-name-2))) + (string-lessp (cdr stroke1) (cdr stroke2))) (defvar strokes-mode-map (let ((map (make-sparse-keymap))) diff --git a/lisp/subr.el b/lisp/subr.el index 2b3231b879b..10c37e94134 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -257,10 +257,9 @@ Then evaluate RESULT to get return value, default nil. ;; use dolist. ;; FIXME: This cost disappears in byte-compiled lexical-binding files. (let ((temp '--dolist-tail--)) - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other is slightly faster (and has cleaner semantics) - ;; with lexical scoping. + ;; This test does not matter much because both semantics are acceptable, + ;; but one is slightly faster with dynamic scoping and the other is + ;; slightly faster (and has cleaner semantics) with lexical scoping. (if lexical-binding `(let ((,temp ,(nth 1 spec))) (while ,temp @@ -292,9 +291,9 @@ the return value (nil if RESULT is omitted). Its use is deprecated. (let ((temp '--dotimes-limit--) (start 0) (end (nth 1 spec))) - ;; This is not a reliable test, but it does not matter because both - ;; semantics are acceptable, tho one is slightly faster with dynamic - ;; scoping and the other has cleaner semantics. + ;; This test does not matter much because both semantics are acceptable, + ;; but one is slightly faster with dynamic scoping and the other has + ;; cleaner semantics. (if lexical-binding (let ((counter '--dotimes-counter--)) `(let ((,temp ,end) @@ -1558,7 +1557,6 @@ be a list of the form returned by `event-start' and `event-end'." ;;;; Obsolescent names for functions. -(make-obsolete 'forward-point "use (+ (point) N) instead." "23.1") (make-obsolete 'buffer-has-markers-at nil "24.3") (make-obsolete 'invocation-directory "use the variable of the same name." @@ -1580,6 +1578,11 @@ be a list of the form returned by `event-start' and `event-end'." (make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") +(defun forward-point (n) + "Return buffer position N characters after (before if N negative) point." + (declare (obsolete "use (+ (point) N) instead." "23.1")) + (+ (point) n)) + (defun log10 (x) "Return (log X 10), the log base 10 of X." (declare (obsolete log "24.4")) @@ -1621,6 +1624,9 @@ be a list of the form returned by `event-start' and `event-end'." (defvaralias 'messages-buffer-max-lines 'message-log-max) (define-obsolete-variable-alias 'inhibit-null-byte-detection 'inhibit-nul-byte-detection "27.1") +(make-obsolete-variable 'load-dangerous-libraries + "no longer used." "27.1") + ;;;; Alternate names for functions - these are not being phased out. @@ -1774,6 +1780,21 @@ all symbols are bound before any of the VALUEFORMs are evalled." ,@(mapcar (lambda (binder) `(setq ,@binder)) binders) ,@body)) +(defmacro dlet (binders &rest body) + "Like `let*' but using dynamic scoping." + (declare (indent 1) (debug let)) + ;; (defvar FOO) only affects the current scope, but in order for + ;; this not to affect code after the `let*' we need to create a new scope, + ;; which is what the surrounding `let' is for. + ;; FIXME: (let () ...) currently doesn't actually create a new scope, + ;; which is why we use (let (_) ...). + `(let (_) + ,@(mapcar (lambda (binder) + `(defvar ,(if (consp binder) (car binder) binder))) + binders) + (let* ,binders ,@body))) + + (defmacro with-wrapper-hook (hook args &rest body) "Run BODY, using wrapper functions from HOOK with additional ARGS. HOOK is an abnormal hook. Each hook function in HOOK \"wraps\" @@ -2263,6 +2284,8 @@ Otherwise TYPE is assumed to be a symbol property." (not (eq 'require (car match))))))) (throw 'found file)))))) +(declare-function read-library-name "find-func" nil) + (defun locate-library (library &optional nosuffix path interactive-call) "Show the precise file name of Emacs library LIBRARY. LIBRARY should be a relative file name of the library, a string. @@ -2279,12 +2302,7 @@ is used instead of `load-path'. When called from a program, the file name is normally returned as a string. When run interactively, the argument INTERACTIVE-CALL is t, and the file name is displayed in the echo area." - (interactive (list (completing-read "Locate library: " - (apply-partially - 'locate-file-completion-table - load-path (get-load-suffixes))) - nil nil - t)) + (interactive (list (read-library-name) nil nil t)) (let ((file (locate-file library (or path load-path) (append (unless nosuffix (get-load-suffixes)) @@ -2521,10 +2539,15 @@ by doing (clear-string STRING)." ;; And of course, don't keep the sensitive data around. (erase-buffer)))))))) -(defun read-number (prompt &optional default) +(defvar read-number-history nil + "The default history for the `read-number' function.") + +(defun read-number (prompt &optional default hist) "Read a numeric value in the minibuffer, prompting with PROMPT. DEFAULT specifies a default value to return if the user just types RET. The value of DEFAULT is inserted into PROMPT. +HIST specifies a history list variable. See `read-from-minibuffer' +for details of the HIST argument. This function is used by the `interactive' code letter `n'." (let ((n nil) (default1 (if (consp default) (car default) default))) @@ -2538,7 +2561,7 @@ This function is used by the `interactive' code letter `n'." (while (progn (let ((str (read-from-minibuffer - prompt nil nil nil nil + prompt nil nil nil (or hist 'read-number-history) (when default (if (consp default) (mapcar 'number-to-string (delq nil default)) @@ -3967,7 +3990,7 @@ the function `undo--wrap-and-run-primitive-undo'." (let (;; (inhibit-modification-hooks t) (before-change-functions ;; Ugly Hack: if the body uses syntax-ppss/syntax-propertize - ;; (e.g. via a regexp-search or sexp-movement trigerring + ;; (e.g. via a regexp-search or sexp-movement triggering ;; on-the-fly syntax-propertize), make sure that this gets ;; properly refreshed after subsequent changes. (if (memq #'syntax-ppss-flush-cache before-change-functions) @@ -4009,7 +4032,7 @@ the function `undo--wrap-and-run-primitive-undo'." (defmacro combine-change-calls (beg end &rest body) "Evaluate BODY, running the change hooks just once. -BODY is a sequence of lisp forms to evaluate. BEG and END bound +BODY is a sequence of Lisp forms to evaluate. BEG and END bound the region the change hooks will be run for. Firstly, `before-change-functions' is invoked for the region @@ -4027,7 +4050,8 @@ change `before-change-functions' or `after-change-functions'. Additionally, the buffer modifications of BODY are recorded on the buffer's undo list as a single \(apply ...) entry containing -the function `undo--wrap-and-run-primitive-undo'. " +the function `undo--wrap-and-run-primitive-undo'." + (declare (debug t) (indent 2)) `(combine-change-calls-1 ,beg ,end (lambda () ,@body))) (defun undo--wrap-and-run-primitive-undo (beg end list) diff --git a/lisp/t-mouse.el b/lisp/t-mouse.el index fc174176cd6..a1af53d8c46 100644 --- a/lisp/t-mouse.el +++ b/lisp/t-mouse.el @@ -1,4 +1,4 @@ -;;; t-mouse.el --- mouse support within the text terminal +;;; t-mouse.el --- mouse support within the text terminal -*- lexical-binding:t -*- ;; Author: Nick Roberts <nickrob@gnu.org> ;; Maintainer: emacs-devel@gnu.org diff --git a/lisp/tab-bar.el b/lisp/tab-bar.el index d97ca37a731..cee88cb4275 100644 --- a/lisp/tab-bar.el +++ b/lisp/tab-bar.el @@ -799,11 +799,14 @@ After the tab is created, the hooks in (run-hook-with-args 'tab-bar-tab-post-open-functions (nth to-index tabs))) - (when (and (not tab-bar-mode) - (or (eq tab-bar-show t) - (and (natnump tab-bar-show) - (> (length tabs) tab-bar-show)))) + (cond + (tab-bar-mode) + ((eq tab-bar-show t) (tab-bar-mode 1)) + ((and (natnump tab-bar-show) + (> (length (funcall tab-bar-tabs-function)) tab-bar-show) + (zerop (frame-parameter nil 'tab-bar-lines))) + (set-frame-parameter nil 'tab-bar-lines 1))) (force-mode-line-update) (unless tab-bar-mode @@ -936,10 +939,11 @@ for the last tab on a frame is determined by tab-bar-closed-tabs) (set-frame-parameter nil 'tabs (delq close-tab tabs))) - (when (and tab-bar-mode - (and (natnump tab-bar-show) - (<= (length tabs) tab-bar-show))) - (tab-bar-mode -1)) + (when (and (not (zerop (frame-parameter nil 'tab-bar-lines))) + (natnump tab-bar-show) + (<= (length (funcall tab-bar-tabs-function)) + tab-bar-show)) + (set-frame-parameter nil 'tab-bar-lines 0)) (force-mode-line-update) (unless tab-bar-mode @@ -975,10 +979,11 @@ for the last tab on a frame is determined by (run-hook-with-args 'tab-bar-tab-pre-close-functions (nth index tabs) nil))) (set-frame-parameter nil 'tabs (list (nth current-index tabs))) - (when (and tab-bar-mode - (and (natnump tab-bar-show) - (<= 1 tab-bar-show))) - (tab-bar-mode -1)) + (when (and (not (zerop (frame-parameter nil 'tab-bar-lines))) + (natnump tab-bar-show) + (<= (length (funcall tab-bar-tabs-function)) + tab-bar-show)) + (set-frame-parameter nil 'tab-bar-lines 0)) (force-mode-line-update) (unless tab-bar-mode @@ -1483,8 +1488,7 @@ This is an action function for buffer display, see Info node `(elisp) Buffer Display Action Functions'. It should be called only by `display-buffer' or a function directly or indirectly called by the latter." - (let* ((tab-name (alist-get 'tab-name alist)) - (reusable-frames (alist-get 'reusable-frames alist)) + (let* ((reusable-frames (alist-get 'reusable-frames alist)) (reusable-tab (when reusable-frames (tab-bar-get-buffer-tab buffer reusable-frames)))) (if reusable-tab @@ -1496,17 +1500,46 @@ indirectly called by the latter." (tab-bar-select-tab (1+ index))) (when (get-buffer-window buffer frame) (select-window (get-buffer-window buffer frame)))) + (let ((tab-name (alist-get 'tab-name alist))) + (when (functionp tab-name) + (setq tab-name (funcall tab-name buffer alist))) + (if tab-name + (let ((tab-index (tab-bar--tab-index-by-name tab-name))) + (if tab-index + (progn + (tab-bar-select-tab (1+ tab-index)) + (when (get-buffer-window buffer) + (select-window (get-buffer-window buffer)))) + (display-buffer-in-new-tab buffer alist))) + (display-buffer-in-new-tab buffer alist)))))) + +(defun display-buffer-in-new-tab (buffer alist) + "Display BUFFER in a new tab. +ALIST is an association list of action symbols and values. See +Info node `(elisp) Buffer Display Action Alists' for details of +such alists. + +Like `display-buffer-in-tab', but always creates a new tab unconditionally, +without checking if a suitable tab already exists. + +If ALIST contains a `tab-name' entry, it creates a new tab with that name +and displays BUFFER in a new tab. The `tab-name' entry can be a function, +then it is called with two arguments: BUFFER and ALIST, and should return +the tab name. When a `tab-name' entry is omitted, create a new tab without +an explicit name. + +This is an action function for buffer display, see Info +node `(elisp) Buffer Display Action Functions'. It should be +called only by `display-buffer' or a function directly or +indirectly called by the latter." + (let ((tab-bar-new-tab-choice t)) + (tab-bar-new-tab) + (let ((tab-name (alist-get 'tab-name alist))) (when (functionp tab-name) (setq tab-name (funcall tab-name buffer alist))) - (if tab-name - (let ((tab-index (tab-bar--tab-index-by-name tab-name))) - (if tab-index - (tab-bar-select-tab (1+ tab-index)) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab) - (tab-bar-rename-tab tab-name)))) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab)))))) + (when tab-name + (tab-bar-rename-tab tab-name))) + (window--display-buffer buffer (selected-window) 'tab alist))) (defun switch-to-buffer-other-tab (buffer-or-name &optional norecord) "Switch to buffer BUFFER-OR-NAME in another tab. @@ -1514,8 +1547,7 @@ Like \\[switch-to-buffer-other-frame] (which see), but creates a new tab." (interactive (list (read-buffer-to-switch "Switch to buffer in other tab: "))) (display-buffer (window-normalize-buffer-to-switch-to buffer-or-name) - '((display-buffer-in-tab - display-buffer-same-window) + '((display-buffer-in-tab) (inhibit-same-window . nil)) norecord)) @@ -1534,6 +1566,25 @@ Like \\[find-file-other-frame] (which see), but creates a new tab." value) (switch-to-buffer-other-tab value)))) +(defun other-tab-prefix () + "Display the buffer of the next command in a new tab. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new tab before displaying the buffer, or switches to the tab +that already contains that buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (cons (progn + (display-buffer-in-tab + buffer (append alist '((inhibit-same-window . nil)))) + (selected-window)) + 'tab)) + nil "[other-tab]") + (message "Display next command buffer in a new tab...")) + (define-key tab-prefix-map "2" 'tab-new) (define-key tab-prefix-map "1" 'tab-close-other) (define-key tab-prefix-map "0" 'tab-close) @@ -1544,6 +1595,7 @@ Like \\[find-file-other-frame] (which see), but creates a new tab." (define-key tab-prefix-map "b" 'switch-to-buffer-other-tab) (define-key tab-prefix-map "f" 'find-file-other-tab) (define-key tab-prefix-map "\C-f" 'find-file-other-tab) +(define-key tab-prefix-map "t" 'other-tab-prefix) (provide 'tab-bar) diff --git a/lisp/tar-mode.el b/lisp/tar-mode.el index 97d883eebd9..73978ffc4a7 100644 --- a/lisp/tar-mode.el +++ b/lisp/tar-mode.el @@ -480,23 +480,9 @@ checksum before doing the check." (defun tar-grind-file-mode (mode) "Construct a `rw-r--r--' string indicating MODE. -MODE should be an integer which is a file mode value." - (string - (if (zerop (logand 256 mode)) ?- ?r) - (if (zerop (logand 128 mode)) ?- ?w) - (if (zerop (logand 2048 mode)) - (if (zerop (logand 64 mode)) ?- ?x) - (if (zerop (logand 64 mode)) ?S ?s)) - (if (zerop (logand 32 mode)) ?- ?r) - (if (zerop (logand 16 mode)) ?- ?w) - (if (zerop (logand 1024 mode)) - (if (zerop (logand 8 mode)) ?- ?x) - (if (zerop (logand 8 mode)) ?S ?s)) - (if (zerop (logand 4 mode)) ?- ?r) - (if (zerop (logand 2 mode)) ?- ?w) - (if (zerop (logand 512 mode)) - (if (zerop (logand 1 mode)) ?- ?x) - (if (zerop (logand 1 mode)) ?T ?t)))) +MODE should be an integer which is a file mode value. +For instance, if mode is #o700, then it produces `rwx------'." + (substring (file-modes-number-to-symbolic mode) 1)) (defun tar-header-block-summarize (tar-hblock &optional mod-p) "Return a line similar to the output of `tar -vtf'." @@ -1056,7 +1042,7 @@ extracted file." (write-region start end to-file nil nil nil t)) (when (and tar-copy-preserve-time date) - (set-file-times to-file date))) + (set-file-times to-file date 'nofollow))) (message "Copied tar entry %s to %s" name to-file))) (defun tar-new-entry (filename &optional index) diff --git a/lisp/tempo.el b/lisp/tempo.el index 9de5ac66c7d..bc398e7eb67 100644 --- a/lisp/tempo.el +++ b/lisp/tempo.el @@ -220,7 +220,9 @@ list of elements in the template, TAG is the tag used for completion, DOCUMENTATION is the documentation string for the insertion command created, and TAGLIST (a symbol) is the tag list that TAG (if provided) should be added to. If TAGLIST is nil and TAG is non-nil, TAG is -added to `tempo-tags'. +added to `tempo-tags'. If TAG already corresponds to a template in +the tag list, modify the list so that TAG now corresponds to the newly +defined template. The elements in ELEMENTS can be of several types: @@ -579,14 +581,20 @@ and insert the results." (defun tempo-add-tag (tag template &optional tag-list) "Add a template tag. Add the TAG, that should complete to TEMPLATE to the list in TAG-LIST, -or to `tempo-tags' if TAG-LIST is nil." +or to `tempo-tags' if TAG-LIST is nil. If TAG was already in the list, +replace its template with TEMPLATE." (interactive "sTag: \nCTemplate: ") (if (null tag-list) (setq tag-list 'tempo-tags)) - (if (not (assoc tag (symbol-value tag-list))) - (set tag-list (cons (cons tag template) (symbol-value tag-list)))) - (tempo-invalidate-collection)) + (let ((entry (assoc tag (symbol-value tag-list)))) + (if entry + ;; Tag is already in the list, assign a new template to it. + (setcdr entry template) + ;; Tag is not present in the list, add it with its template. + (set tag-list (cons (cons tag template) (symbol-value tag-list))))) + ;; Invalidate globally if we're modifying 'tempo-tags'. + (tempo-invalidate-collection (eq tag-list 'tempo-tags))) ;;; ;;; tempo-use-tag-list @@ -609,10 +617,17 @@ COMPLETION-FUNCTION just sets `tempo-match-finder' locally." ;;; ;;; tempo-invalidate-collection -(defun tempo-invalidate-collection () +(defun tempo-invalidate-collection (&optional global) "Marks the tag collection as obsolete. -Whenever it is needed again it will be rebuilt." - (setq tempo-dirty-collection t)) +Whenever it is needed again it will be rebuilt. If GLOBAL is non-nil, +mark the tag collection of all buffers as obsolete, not just the +current one." + (if global + (dolist (buffer (buffer-list)) + (with-current-buffer buffer + (when (assq 'tempo-dirty-collection (buffer-local-variables)) + (setq tempo-dirty-collection t)))) + (setq tempo-dirty-collection t))) ;;; ;;; tempo-build-collection diff --git a/lisp/term.el b/lisp/term.el index 09dfeb61d17..b990c83cfcb 100644 --- a/lisp/term.el +++ b/lisp/term.el @@ -2796,12 +2796,12 @@ See `term-prompt-regexp'." "\\(?:[\r\n\000\007\t\b\016\017]\\|" ;; some Emacs specific control sequences, implemented by ;; `term-command-hook', - "\032[^\n]+\r?\n\\|" + "\032[^\n]+\n\\|" ;; a C1 escape coded character (see [ECMA-48] section 5.3 "Elements ;; of the C1 set"), "\e\\(?:[DM78c]\\|" ;; another Emacs specific control sequence, - "AnSiT[^\n]+\r?\n\\|" + "AnSiT[^\n]+\n\\|" ;; or an escape sequence (section 5.4 "Control Sequences"), "\\[\\([\x30-\x3F]*\\)[\x20-\x2F]*[\x40-\x7E]\\)\\)") "Regexp matching control sequences handled by term.el.") diff --git a/lisp/term/bobcat.el b/lisp/term/bobcat.el index a32da6ae8f2..983c8cded2f 100644 --- a/lisp/term/bobcat.el +++ b/lisp/term/bobcat.el @@ -1,3 +1,4 @@ +;;; bobcat.el -*- lexical-binding:t -*- (defun terminal-init-bobcat () "Terminal initialization function for bobcat." diff --git a/lisp/term/cygwin.el b/lisp/term/cygwin.el index edc64b4404d..8f0d751cf29 100644 --- a/lisp/term/cygwin.el +++ b/lisp/term/cygwin.el @@ -1,4 +1,4 @@ -;;; cygwin.el --- support for the Cygwin terminal +;;; cygwin.el --- support for the Cygwin terminal -*- lexical-binding:t -*- ;;; The Cygwin terminal can't really display underlines. diff --git a/lisp/term/konsole.el b/lisp/term/konsole.el index 8b2e7e1d5f8..4af818b4a63 100644 --- a/lisp/term/konsole.el +++ b/lisp/term/konsole.el @@ -1,4 +1,4 @@ -;;; konsole.el --- terminal initialization for konsole +;;; konsole.el --- terminal initialization for konsole -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. (require 'term/xterm) diff --git a/lisp/term/linux.el b/lisp/term/linux.el index 70730dc5844..35bd3ac0acb 100644 --- a/lisp/term/linux.el +++ b/lisp/term/linux.el @@ -1,4 +1,4 @@ -;; The Linux console handles Latin-1 by default. +;; The Linux console handles Latin-1 by default. -*- lexical-binding:t -*- (declare-function gpm-mouse-enable "t-mouse" ()) diff --git a/lisp/term/ns-win.el b/lisp/term/ns-win.el index 90024b001f7..6acf6cd1992 100644 --- a/lisp/term/ns-win.el +++ b/lisp/term/ns-win.el @@ -314,10 +314,9 @@ The overlay is assigned the face `ns-working-text-face'." (interactive) (ns-delete-working-text) (let ((start (point))) - (insert ns-working-text) - (overlay-put (setq ns-working-overlay (make-overlay start (point) - (current-buffer) nil t)) - 'face 'ns-working-text-face))) + (overlay-put (setq ns-working-overlay (make-overlay start (point))) + 'after-string + (propertize ns-working-text 'face 'ns-working-text-face)))) (defun ns-echo-working-text () "Echo contents of `ns-working-text' in message display area. @@ -340,8 +339,7 @@ See `ns-insert-working-text'." ;; Still alive? (overlay-buffer ns-working-overlay)) (with-current-buffer (overlay-buffer ns-working-overlay) - (delete-region (overlay-start ns-working-overlay) - (overlay-end ns-working-overlay)) + (overlay-put ns-working-overlay 'after-string nil) (delete-overlay ns-working-overlay))) ((integerp ns-working-overlay) (let ((msg (current-message)) diff --git a/lisp/term/rxvt.el b/lisp/term/rxvt.el index ca6c468f525..31e3d6ede4f 100644 --- a/lisp/term/rxvt.el +++ b/lisp/term/rxvt.el @@ -26,6 +26,16 @@ (require 'term/xterm) +(defgroup rxvt nil + "(U)RXVT support." + :version "28.1" + :group 'terminals) + +(defcustom rxvt-set-window-title nil + "Whether Emacs should set window titles to an Emacs frame in RXVT." + :version "28.1" + :type 'boolean) + (defvar rxvt-function-map (let ((map (make-sparse-keymap))) (set-keymap-parent map xterm-rxvt-function-map) @@ -171,7 +181,16 @@ (xterm-register-default-colors rxvt-standard-colors) (rxvt-set-background-mode) ;; This recomputes all the default faces given the colors we've just set up. - (tty-set-up-initial-frame-faces)) + (tty-set-up-initial-frame-faces) + + ;; Unconditionally enable bracketed paste mode: terminals that don't + ;; support it just ignore the sequence. + (xterm--init-bracketed-paste-mode) + + (when rxvt-set-window-title + (xterm--init-frame-title)) + + (run-hooks 'terminal-init-rxvt-hook)) ;; rxvt puts the default colors into an environment variable ;; COLORFGBG. We use this to set the background mode in a more diff --git a/lisp/term/tty-colors.el b/lisp/term/tty-colors.el index 39ca2d36276..dda7fcc3691 100644 --- a/lisp/term/tty-colors.el +++ b/lisp/term/tty-colors.el @@ -923,62 +923,8 @@ The returned value reflects the standard Emacs definition of COLOR (see the info node `(emacs) Colors'), regardless of whether the terminal can display it, so the return value should be the same regardless of what display is being used." - (let ((len (length color))) - (cond ((and (>= len 4) ;; HTML/CSS/SVG-style "#XXYYZZ" color spec - (eq (aref color 0) ?#) - (member (aref color 1) - '(?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9 - ?a ?b ?c ?d ?e ?f - ?A ?B ?C ?D ?E ?F))) - ;; Translate the string "#XXYYZZ" into a list of numbers - ;; (XX YY ZZ), scaling each to the {0..65535} range. This - ;; follows the HTML color convention, where both "#fff" and - ;; "#ffffff" represent the same color, white. - (let* ((ndig (/ (- len 1) 3)) - (maxval (1- (ash 1 (* 4 ndig)))) - (i1 1) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 i2) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 i3) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 i4) 16) - 65535) - maxval)))) - ((and (>= len 9) ;; X-style rgb:xx/yy/zz color spec - (string= (substring color 0 4) "rgb:")) - ;; Translate the string "rgb:XX/YY/ZZ" into a list of - ;; numbers (XX YY ZZ), scaling each to the {0..65535} - ;; range. "rgb:F/F/F" is white. - (let* ((ndig (/ (- len 3) 3)) - (maxval (1- (ash 1 (* 4 (- ndig 1))))) - (i1 4) - (i2 (+ i1 ndig)) - (i3 (+ i2 ndig)) - (i4 (+ i3 ndig))) - (list - (/ (* (string-to-number - (substring color i1 (- i2 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i2 (- i3 1)) 16) - 65535) - maxval) - (/ (* (string-to-number - (substring color i3 (1- i4)) 16) - 65535) - maxval)))) - (t - (cdr (assoc color color-name-rgb-alist)))))) + (or (color-values-from-color-spec color) + (cdr (assoc color color-name-rgb-alist)))) (defun tty-color-translate (color &optional frame) "Given a color COLOR, return the index of the corresponding TTY color. diff --git a/lisp/term/vt100.el b/lisp/term/vt100.el index 7ddbe38a287..2df14145231 100644 --- a/lisp/term/vt100.el +++ b/lisp/term/vt100.el @@ -1,4 +1,4 @@ -;;; vt100.el --- define VT100 function key sequences in function-key-map +;;; vt100.el --- define VT100 function key sequences in function-key-map -*- lexical-binding:t -*- ;; Copyright (C) 1989, 1993, 2001-2020 Free Software Foundation, Inc. diff --git a/lisp/term/vt200.el b/lisp/term/vt200.el index dde2e229068..569b79e25a1 100644 --- a/lisp/term/vt200.el +++ b/lisp/term/vt200.el @@ -1,3 +1,5 @@ +;;; vt200.el -*- lexical-binding:t -*- + ;; For our purposes we can treat the vt200 and vt100 almost alike. ;; Most differences are handled by the termcap entry. (defun terminal-init-vt200 () diff --git a/lisp/term/w32-win.el b/lisp/term/w32-win.el index 3e932c7593d..5901e0295e1 100644 --- a/lisp/term/w32-win.el +++ b/lisp/term/w32-win.el @@ -231,6 +231,8 @@ See the documentation of `create-fontset-from-fontset-spec' for the format.") ;;; Set default known names for external libraries (setq dynamic-library-alist (list + '(gdiplus "gdiplus.dll") + '(shlwapi "shlwapi.dll") '(xpm "libxpm.dll" "xpm4.dll" "libXpm-nox4.dll") ;; Versions of libpng 1.4.x and later are incompatible with ;; earlier versions. Set up the list of libraries according to diff --git a/lisp/term/x-win.el b/lisp/term/x-win.el index 5b8feb14a5e..42a6f4030e5 100644 --- a/lisp/term/x-win.el +++ b/lisp/term/x-win.el @@ -1407,13 +1407,13 @@ This returns an error if any Emacs frames are X frames." ("etc/images/right-arrow" . ("go-next" "gtk-go-forward")) ("etc/images/home" . ("go-home" "gtk-home")) ("etc/images/jump-to" . ("go-jump" "gtk-jump-to")) - ("etc/images/index" . "gtk-index") + ("etc/images/index" . ("gtk-search" "gtk-index")) ("etc/images/exit" . ("application-exit" "gtk-quit")) ("etc/images/cancel" . "gtk-cancel") ("etc/images/info" . ("dialog-information" "gtk-info")) ("etc/images/bookmark_add" . "n:bookmark_add") ;; Used in Gnus and/or MH-E: - ("etc/images/attach" . "gtk-attach") + ("etc/images/attach" . ("mail-attachment" "gtk-attach")) ("etc/images/connect" . "gtk-connect") ("etc/images/contact" . "gtk-contact") ("etc/images/delete" . ("edit-delete" "gtk-delete")) @@ -1425,14 +1425,16 @@ This returns an error if any Emacs frames are X frames." ("etc/images/lock" . "gtk-lock") ("etc/images/next-page" . "gtk-next-page") ("etc/images/refresh" . ("view-refresh" "gtk-refresh")) + ("etc/images/search-replace" . "edit-find-replace") ("etc/images/sort-ascending" . ("view-sort-ascending" "gtk-sort-ascending")) ("etc/images/sort-column-ascending" . "gtk-sort-column-ascending") ("etc/images/sort-criteria" . "gtk-sort-criteria") ("etc/images/sort-descending" . ("view-sort-descending" "gtk-sort-descending")) ("etc/images/sort-row-ascending" . "gtk-sort-row-ascending") + ("etc/images/spell" . ("tools-check-spelling" "gtk-spell-check")) ("images/gnus/toggle-subscription" . "gtk-task-recurring") - ("images/mail/compose" . "gtk-mail-compose") + ("images/mail/compose" . ("mail-message-new" "gtk-mail-compose")) ("images/mail/copy" . "gtk-mail-copy") ("images/mail/forward" . "gtk-mail-forward") ("images/mail/inbox" . "gtk-inbox") @@ -1442,7 +1444,7 @@ This returns an error if any Emacs frames are X frames." ("images/mail/reply-all" . "gtk-mail-reply-to-all") ("images/mail/reply" . "gtk-mail-reply") ("images/mail/save-draft" . "gtk-mail-handling") - ("images/mail/send" . "gtk-mail-send") + ("images/mail/send" . ("mail-send" "gtk-mail-send")) ("images/mail/spam" . "gtk-spam") ;; Used for GDB Graphical Interface ("images/gud/break" . "gtk-no") diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 670e763814c..0018b89d858 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -440,7 +440,7 @@ If parsing fails, try to set this variable to nil." "Alist of BibTeX entry types and their associated fields. Elements are lists (ENTRY-TYPE DOC REQUIRED CROSSREF OPTIONAL). ENTRY-TYPE is the type of a BibTeX entry. -DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used. +DOC is a brief doc string used for menus. If nil ENTRY-TYPE is used. REQUIRED is a list of required fields. CROSSREF is a list of fields that are optional if a crossref field is present; but these fields are required otherwise. @@ -850,11 +850,11 @@ Predefined dialects include BibTeX and biblatex." To interactively change the dialect use the command `bibtex-set-dialect'." :group 'bibtex :version "24.1" - :set '(lambda (symbol value) - (set-default symbol value) - ;; `bibtex-set-dialect' is undefined during loading (no problem) - (if (fboundp 'bibtex-set-dialect) - (bibtex-set-dialect value))) + :set (lambda (symbol value) + (set-default symbol value) + ;; `bibtex-set-dialect' is undefined during loading (no problem). + (if (fboundp 'bibtex-set-dialect) + (bibtex-set-dialect value))) :type '(choice (const BibTeX) (const biblatex) (symbol :tag "Custom"))) @@ -1051,7 +1051,7 @@ See `bibtex-generate-autokey' for details." (defvaralias 'bibtex-autokey-name-case-convert 'bibtex-autokey-name-case-convert-function) -(defcustom bibtex-autokey-name-case-convert-function 'downcase +(defcustom bibtex-autokey-name-case-convert-function #'downcase "Function called for each name to perform case conversion. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey @@ -1127,7 +1127,7 @@ Case is significant. See `bibtex-generate-autokey' for details." (defvaralias 'bibtex-autokey-titleword-case-convert 'bibtex-autokey-titleword-case-convert-function) -(defcustom bibtex-autokey-titleword-case-convert-function 'downcase +(defcustom bibtex-autokey-titleword-case-convert-function #'downcase "Function called for each titleword to perform case conversion. See `bibtex-generate-autokey' for details." :group 'bibtex-autokey @@ -1188,12 +1188,13 @@ See `bibtex-generate-autokey' for details." :group 'bibtex-autokey :type 'boolean) -(defcustom bibtex-autokey-before-presentation-function nil - "If non-nil, function to call before generated key is presented. +(defcustom bibtex-autokey-before-presentation-function #'identity + "Function to call before generated key is presented. The function must take one argument (the automatically generated key), and must return a string (the key to use)." :group 'bibtex-autokey - :type '(choice (const nil) function)) + :version "28.1" + :type 'function) (defcustom bibtex-entry-offset 0 "Offset for BibTeX entries. @@ -1242,7 +1243,7 @@ If non-nil, the column for the equal sign is the value of :group 'bibtex :type '(repeat string)) -(defcustom bibtex-summary-function 'bibtex-summary +(defcustom bibtex-summary-function #'bibtex-summary "Function to call for generating a summary of current BibTeX entry. It takes no arguments. Point must be at beginning of entry. Used by `bibtex-complete-crossref-cleanup' and `bibtex-copy-summary-as-kill'." @@ -1660,7 +1661,7 @@ Initialized by `bibtex-set-dialect'.") (defvar bibtex-font-lock-url-regexp ;; Assume that field names begin at the beginning of a line. (concat "^[ \t]*" - (regexp-opt (delete-dups (mapcar 'caar bibtex-generate-url-list)) t) + (regexp-opt (delete-dups (mapcar #'caar bibtex-generate-url-list)) t) "[ \t]*=[ \t]*") "Regexp for `bibtex-font-lock-url' derived from `bibtex-generate-url-list'.") @@ -1892,14 +1893,16 @@ If `bibtex-expand-strings' is non-nil, also expand BibTeX strings." (let ((mtch (match-string-no-properties 0))) (push (or (if bibtex-expand-strings (cdr (assoc-string mtch (bibtex-strings) t))) - mtch) content) + mtch) + content) (goto-char (match-end 0))) (let ((bounds (bibtex-parse-field-string))) (push (buffer-substring-no-properties - (1+ (car bounds)) (1- (cdr bounds))) content) + (1+ (car bounds)) (1- (cdr bounds))) + content) (goto-char (cdr bounds)))) (re-search-forward "\\=[ \t\n]*#[ \t\n]*" nil t)) - (apply 'concat (nreverse content)))) + (apply #'concat (nreverse content)))) (buffer-substring-no-properties (bibtex-start-of-text-in-field bounds) (bibtex-end-of-text-in-field bounds)))) @@ -2239,8 +2242,9 @@ Optional arg BEG is beginning of entry." Optional arg COMMA is as in `bibtex-enclosing-field'." (unless bibtex-last-kill-command (error "BibTeX kill ring is empty")) (let ((fun (lambda (kryp kr) ; adapted from `current-kill' - (car (set kryp (nthcdr (mod (- n (length (eval kryp))) - (length kr)) kr)))))) + (car (set kryp (nthcdr (mod (- n (length (symbol-value kryp))) + (length kr)) + kr)))))) ;; We put the mark at the beginning of the inserted field or entry ;; and point at its end - a behavior similar to what `yank' does. ;; The mark is then used by `bibtex-yank-pop', which needs to know @@ -2251,7 +2255,8 @@ Optional arg COMMA is as in `bibtex-enclosing-field'." (goto-char (bibtex-end-of-field (bibtex-enclosing-field comma))) (push-mark) (bibtex-make-field (funcall fun 'bibtex-field-kill-ring-yank-pointer - bibtex-field-kill-ring) t nil t)) + bibtex-field-kill-ring) + t nil t)) ;; insert past the current entry (bibtex-skip-to-valid-entry) (push-mark) @@ -2615,7 +2620,7 @@ Return optimized value to be used by `bibtex-format-entry'." regexp-alist)) (let (opt-list) ;; Loop over field names - (dolist (field (delete-dups (apply 'append (mapcar 'car regexp-alist)))) + (dolist (field (delete-dups (apply #'append (mapcar #'car regexp-alist)))) (let (rules) ;; Collect all matches we have for this field name (dolist (e regexp-alist) @@ -2623,7 +2628,7 @@ Return optimized value to be used by `bibtex-format-entry'." (push (cons (nth 1 e) (nth 2 e)) rules))) (if (eq type 'braces) ;; concatenate all regexps to a single regexp - (setq rules (concat "\\(?:" (mapconcat 'car rules "\\|") "\\)"))) + (setq rules (concat "\\(?:" (mapconcat #'car rules "\\|") "\\)"))) ;; create list of replacement rules. (push (cons field rules) opt-list))) opt-list)) @@ -2674,7 +2679,7 @@ and `bibtex-autokey-names-stretch'." (if (string= "" names) names (let* ((case-fold-search t) - (name-list (mapcar 'bibtex-autokey-demangle-name + (name-list (mapcar #'bibtex-autokey-demangle-name (split-string names "[ \t\n]+and[ \t\n]+"))) additional-names) (unless (or (not (numberp bibtex-autokey-names)) @@ -2686,7 +2691,7 @@ and `bibtex-autokey-names-stretch'." bibtex-autokey-names) (nreverse name-list))) additional-names bibtex-autokey-additional-names)) - (concat (mapconcat 'identity name-list + (concat (mapconcat #'identity name-list bibtex-autokey-name-separator) additional-names))))) @@ -2736,7 +2741,7 @@ Return the result as a string." ;; specific words and use only a specific amount of words. (let ((counter 0) (ignore-re (concat "\\`\\(?:" - (mapconcat 'identity + (mapconcat #'identity bibtex-autokey-titleword-ignore "\\|") "\\)\\'")) titlewords titlewords-extra word) @@ -2760,7 +2765,7 @@ Return the result as a string." ;; titlewords-extra in titlewords. Otherwise, we ignore titlewords-extra. (unless (string-match "\\b\\w+" titlestring) (setq titlewords (append titlewords-extra titlewords))) - (mapconcat 'bibtex-autokey-demangle-title (nreverse titlewords) + (mapconcat #'bibtex-autokey-demangle-title (nreverse titlewords) bibtex-autokey-titleword-separator)))) (defun bibtex-autokey-demangle-title (titleword) @@ -2837,7 +2842,7 @@ Concatenate the key: non-empty insert `bibtex-autokey-name-year-separator' between the two. If the title part and the year (or name) part are non-empty, insert `bibtex-autokey-year-title-separator' between the two. - 2. If `bibtex-autokey-before-presentation-function' is non-nil, it must be + 2. `bibtex-autokey-before-presentation-function' must be a function taking one argument. Call this function with the generated key as the argument. Use the return value of this function (a string) as the key. @@ -2865,7 +2870,7 @@ Concatenate the key: (defun bibtex-global-key-alist () "Return global key alist based on `bibtex-files'." (if bibtex-files - (apply 'append + (apply #'append (mapcar (lambda (buf) (with-current-buffer buf bibtex-reference-keys)) ;; include current buffer only if it uses `bibtex-mode' @@ -3129,7 +3134,7 @@ does not use `bibtex-mode'." (if buffer-list (switch-to-buffer (completing-read "Switch to BibTeX buffer: " - (mapcar 'buffer-name buffer-list) + (mapcar #'buffer-name buffer-list) nil t (if current (buffer-name (current-buffer))))) (message "No BibTeX buffers defined"))) @@ -3178,7 +3183,7 @@ that is generated by calling `bibtex-url'." Used as default value of `bibtex-summary-function'." ;; It would be neat to make this function customizable. How? (if (looking-at bibtex-entry-maybe-empty-head) - (let* ((bibtex-autokey-name-case-convert-function 'identity) + (let* ((bibtex-autokey-name-case-convert-function #'identity) (bibtex-autokey-name-length 'infty) (bibtex-autokey-names 1) (bibtex-autokey-names-stretch 0) @@ -3189,7 +3194,7 @@ Used as default value of `bibtex-summary-function'." (year (bibtex-autokey-get-year)) (bibtex-autokey-titlewords 5) (bibtex-autokey-titlewords-stretch 2) - (bibtex-autokey-titleword-case-convert-function 'identity) + (bibtex-autokey-titleword-case-convert-function #'identity) (bibtex-autokey-titleword-length 5) (bibtex-autokey-titleword-separator " ") (title (bibtex-autokey-get-title)) @@ -3336,12 +3341,12 @@ BOUND limits the search." (define-button-type 'bibtex-url 'action 'bibtex-button-action - 'bibtex-function 'bibtex-url + 'bibtex-function #'bibtex-url 'help-echo (purecopy "mouse-2, RET: follow URL")) (define-button-type 'bibtex-search-crossref 'action 'bibtex-button-action - 'bibtex-function 'bibtex-search-crossref + 'bibtex-function #'bibtex-search-crossref 'help-echo (purecopy "mouse-2, RET: follow crossref")) (defun bibtex-button (beg end type &rest args) @@ -3405,7 +3410,7 @@ if that value is non-nil. \\{bibtex-mode-map}" (add-hook 'completion-at-point-functions - 'bibtex-completion-at-point-function nil 'local) + #'bibtex-completion-at-point-function nil 'local) (make-local-variable 'bibtex-buffer-last-parsed-tick) ;; Install stealthy parse function if not already installed (unless bibtex-parse-idle-timer @@ -3419,7 +3424,7 @@ if that value is non-nil. (set (make-local-variable 'comment-column) 0) (set (make-local-variable 'defun-prompt-regexp) "^[ \t]*@[[:alnum:]]+[ \t]*") (set (make-local-variable 'outline-regexp) "[ \t]*@") - (set (make-local-variable 'fill-paragraph-function) 'bibtex-fill-field) + (set (make-local-variable 'fill-paragraph-function) #'bibtex-fill-field) (set (make-local-variable 'fill-prefix) (make-string (+ bibtex-entry-offset bibtex-contline-indentation) ?\s)) (set (make-local-variable 'font-lock-defaults) @@ -3441,7 +3446,7 @@ if that value is non-nil. (syntax-propertize-via-font-lock bibtex-font-lock-syntactic-keywords)) ;; Allow `bibtex-dialect' as a file-local variable. - (add-hook 'hack-local-variables-hook 'bibtex-set-dialect nil t)) + (add-hook 'hack-local-variables-hook #'bibtex-set-dialect nil t)) (defun bibtex-entry-alist (dialect) "Return entry-alist for DIALECT." @@ -3488,8 +3493,9 @@ are also bound buffer-locally if `bibtex-dialect' is already buffer-local in the current buffer (for example, as a file-local variable). LOCAL is t for interactive calls." (interactive (list (intern (completing-read "Dialect: " - (mapcar 'list bibtex-dialect-list) - nil t)) t)) + (mapcar #'list bibtex-dialect-list) + nil t)) + t)) (let ((setfun (if (or local (local-variable-p 'bibtex-dialect)) (lambda (var val) (set (make-local-variable var) val)) 'set))) @@ -3506,7 +3512,7 @@ LOCAL is t for interactive calls." bibtex-dialect)))) (funcall setfun 'bibtex-entry-type (concat "@[ \t]*\\(?:" - (regexp-opt (mapcar 'car bibtex-entry-alist)) "\\)")) + (regexp-opt (mapcar #'car bibtex-entry-alist)) "\\)")) (funcall setfun 'bibtex-entry-head (concat "^[ \t]*\\(" bibtex-entry-type "\\)[ \t]*[({][ \t\n]*\\(" bibtex-reference-key "\\)")) @@ -3516,7 +3522,7 @@ LOCAL is t for interactive calls." (concat "^[ \t]*@[ \t]*\\(?:" (regexp-opt (append '("String" "Preamble") - (mapcar 'car bibtex-entry-alist))) "\\)")) + (mapcar #'car bibtex-entry-alist))) "\\)")) (setq imenu-generic-expression (list (list nil bibtex-entry-head bibtex-key-in-head)) imenu-case-fold-search t))) @@ -3549,11 +3555,13 @@ LOCAL is t for interactive calls." (let* ((entry (car elt)) (fname (intern (format "bibtex-%s" entry)))) (unless (fboundp fname) - (eval (list 'defun fname nil - (format "Insert a template for a @%s entry; see also `bibtex-entry'." - entry) - '(interactive "*") - `(bibtex-entry ,entry)))) + (defalias fname + (lambda () + (:documentation + (format "Insert a template for a @%s entry; see also `bibtex-entry'." + entry)) + (interactive "*") + (bibtex-entry entry)))) ;; Menu entries (define-key menu-map (vector fname) `(menu-item ,(or (nth 1 elt) (car elt)) ,fname)))) @@ -3608,8 +3616,8 @@ is non-nil." (insert "@" entry-type (bibtex-entry-left-delimiter)) (if key (insert key)) (save-excursion - (mapc 'bibtex-make-field (car field-list)) - (mapc 'bibtex-make-optional-field (cdr field-list)) + (mapc #'bibtex-make-field (car field-list)) + (mapc #'bibtex-make-optional-field (cdr field-list)) (if bibtex-comma-after-last-field (insert ",")) (insert "\n") @@ -3657,8 +3665,8 @@ When called interactively with a prefix arg, query for a value of ENTRY-TYPE." (insert (bibtex-field-left-delimiter))) (goto-char end))) (skip-chars-backward " \t\n") - (mapc 'bibtex-make-field required) - (mapc 'bibtex-make-optional-field optional))))) + (mapc #'bibtex-make-field required) + (mapc #'bibtex-make-optional-field optional))))) (defun bibtex-parse-entry (&optional content keep-opt-alt) "Parse entry at point, return an alist. @@ -4980,7 +4988,8 @@ If mark is active reformat entries in region, if not in whole buffer." ("Remove empty optional and alternative fields? " . opts-or-alts) ("Remove delimiters around pure numerical fields? " . numerical-fields) (,(concat (if bibtex-comma-after-last-field "Insert" "Remove") - " comma at end of entry? ") . last-comma) + " comma at end of entry? ") + . last-comma) ("Replace double page dashes by single ones? " . page-dashes) ("Delete whitespace at the beginning and end of fields? " . whitespace) ("Inherit booktitle? " . inherit-booktitle) @@ -5047,7 +5056,7 @@ entries from minibuffer." (goto-char (point-max)) (message "Buffer is now parsable. Please save it."))) -(define-obsolete-function-alias 'bibtex-complete 'completion-at-point "24.1") +(define-obsolete-function-alias 'bibtex-complete #'completion-at-point "24.1") (defun bibtex-completion-at-point-function () (let ((pnt (point)) (case-fold-search t) @@ -5258,8 +5267,8 @@ Return the URL or nil if none can be generated." ;; If SCHEME is set up correctly, ;; we should never reach this point (error "Match failed: %s" text))) - (if fmt (apply 'format fmt (nreverse obj)) - (apply 'concat (nreverse obj))))) + (if fmt (apply #'format fmt (nreverse obj)) + (apply #'concat (nreverse obj))))) (if (called-interactively-p 'interactive) (message "%s" url)) (unless no-browse (browse-url url))) (if (and (not url) (called-interactively-p 'interactive)) @@ -5289,10 +5298,11 @@ where FILE is the BibTeX file of ENTRY." (list (completing-read "Field: " (delete-dups - (apply 'append + (apply #'append bibtex-user-optional-fields - (mapcar (lambda (x) (mapcar 'car (apply 'append (nthcdr 2 x)))) - bibtex-entry-alist))) nil t) + (mapcar (lambda (x) (mapcar #'car (apply #'append (nthcdr 2 x)))) + bibtex-entry-alist))) + nil t) (read-string "Regexp: ") (if bibtex-search-entry-globally (not current-prefix-arg) diff --git a/lisp/textmodes/conf-mode.el b/lisp/textmodes/conf-mode.el index 86db6980433..722fc0a3137 100644 --- a/lisp/textmodes/conf-mode.el +++ b/lisp/textmodes/conf-mode.el @@ -44,28 +44,23 @@ "Align assignments to this column by default with \\[conf-align-assignments]. If this number is negative, the `=' comes before the whitespace. Use 0 to not align (only setting space according to `conf-assignment-space')." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-javaprop-assignment-column 32 "Value for `conf-assignment-column' in Java properties buffers." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-colon-assignment-column (- (abs conf-assignment-column)) "Value for `conf-assignment-column' in Java properties buffers." - :type 'integer - :group 'conf) + :type 'integer) (defcustom conf-assignment-space t "Put at least one space around assignments when aligning." - :type 'boolean - :group 'conf) + :type 'boolean) (defcustom conf-colon-assignment-space nil "Value for `conf-assignment-space' in colon style Conf mode buffers." - :type 'boolean - :group 'conf) + :type 'boolean) (defvar conf-mode-map (let ((map (make-sparse-keymap)) @@ -349,9 +344,37 @@ unbalanced, but hey...)" (scan-error depth)))) +(defun conf--guess-mode () + "Try to guess sub-mode of `conf-mode' based on buffer content." + (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0)) + (save-excursion + (goto-char (point-min)) + (while (not (eobp)) + (skip-chars-forward " \t\f") + (cond ((eq (char-after) ?\#) (setq unix (1+ unix))) + ((eq (char-after) ?\;) (setq win (1+ win))) + ((eq (char-after) ?\[)) ; nop + ((eolp)) ; nop + ((eq (char-after) ?})) ; nop + ;; recognize at most double spaces within names + ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]") + (if (eq (char-before (match-end 0)) ?=) + (setq equal (1+ equal)) + (setq colon (1+ colon)))) + ((looking-at "/[/*]") (setq jp (1+ jp))) + ((looking-at ".*{")) ; nop + ((setq space (1+ space)))) + (forward-line))) + (cond + ((> jp (max unix win 3)) #'conf-javaprop-mode) + ((> colon (max equal space)) #'conf-colon-mode) + ((> space (max equal colon)) #'conf-space-mode) + ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt))) + #'conf-windows-mode) + (t #'conf-unix-mode)))) ;;;###autoload -(defun conf-mode () +(define-derived-mode conf-mode nil "Conf[?]" "Mode for Unix and Windows Conf files and Java properties. Most conf files know only three kinds of constructs: parameter assignments optionally grouped into sections and comments. Yet @@ -382,75 +405,41 @@ See also `conf-space-mode', `conf-colon-mode', `conf-javaprop-mode', \\{conf-mode-map}" - (interactive) - ;; `conf-mode' plays two roles: it's the parent of several sub-modes - ;; but it's also the function that chooses between those submodes. - ;; To tell the difference between those two cases where the function - ;; might be called, we check `delay-mode-hooks'. - ;; (adopted from tex-mode.el) - (if (not delay-mode-hooks) - ;; try to guess sub-mode of conf-mode based on buffer content - (let ((unix 0) (win 0) (equal 0) (colon 0) (space 0) (jp 0)) - (save-excursion - (goto-char (point-min)) - (while (not (eobp)) - (skip-chars-forward " \t\f") - (cond ((eq (char-after) ?\#) (setq unix (1+ unix))) - ((eq (char-after) ?\;) (setq win (1+ win))) - ((eq (char-after) ?\[)) ; nop - ((eolp)) ; nop - ((eq (char-after) ?})) ; nop - ;; recognize at most double spaces within names - ((looking-at "[^ \t\n=:]+\\(?: ?[^ \t\n=:]+\\)*[ \t]*[=:]") - (if (eq (char-before (match-end 0)) ?=) - (setq equal (1+ equal)) - (setq colon (1+ colon)))) - ((looking-at "/[/*]") (setq jp (1+ jp))) - ((looking-at ".*{")) ; nop - ((setq space (1+ space)))) - (forward-line))) - (cond - ((> jp (max unix win 3)) (conf-javaprop-mode)) - ((> colon (max equal space)) (conf-colon-mode)) - ((> space (max equal colon)) (conf-space-mode)) - ((or (> win unix) (and (= win unix) (eq system-type 'windows-nt))) - (conf-windows-mode)) - (t (conf-unix-mode)))) - - (kill-all-local-variables) - (use-local-map conf-mode-map) - (setq major-mode 'conf-mode - mode-name "Conf[?]") - (set (make-local-variable 'font-lock-defaults) - '(conf-font-lock-keywords nil t nil nil)) - ;; Let newcomment.el decide this for itself. - ;; (set (make-local-variable 'comment-use-syntax) t) - (set (make-local-variable 'parse-sexp-ignore-comments) t) - (set (make-local-variable 'outline-regexp) - "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") - (set (make-local-variable 'outline-heading-end-regexp) - "[\n}]") - (set (make-local-variable 'outline-level) - 'conf-outline-level) - (set-syntax-table conf-mode-syntax-table) - (setq imenu-generic-expression - '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) - ;; [section] - (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) - ;; section { ... } - (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1))) - (run-mode-hooks 'conf-mode-hook))) + (setq-local font-lock-defaults '(conf-font-lock-keywords nil t nil nil)) + ;; Let newcomment.el decide this for itself. + ;; (setq-local comment-use-syntax t) + (setq-local parse-sexp-ignore-comments t) + (setq-local outline-regexp "[ \t]*\\(?:\\[\\|.+[ \t\n]*{\\)") + (setq-local outline-heading-end-regexp "[\n}]") + (setq-local outline-level #'conf-outline-level) + (setq-local imenu-generic-expression + '(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*=" 1) + ;; [section] + (nil "^[ \t]*\\[[ \t]*\\(.+\\)[ \t]*\\]" 1) + ;; section { ... } + (nil "^[ \t]*\\([^=:{} \t\n][^=:{}\n]+\\)[ \t\n]*{" 1)))) + +;; `conf-mode' plays two roles: it's the parent of several sub-modes +;; but it's also the function that chooses between those submodes. +;; To tell the difference between those two cases where the function +;; might be called, we check `delay-mode-hooks'. +;; (inspired from tex-mode.el) +(advice-add 'conf-mode :around + (lambda (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks orig-fun (conf--guess-mode))))) + + (defun conf-mode-initialize (comment &optional font-lock) "Initializations for sub-modes of `conf-mode'. COMMENT initializes `comment-start' and `comment-start-skip'. The optional arg FONT-LOCK is the value for FONT-LOCK-KEYWORDS." - (set (make-local-variable 'comment-start) comment) - (set (make-local-variable 'comment-start-skip) - (concat (regexp-quote comment-start) "+\\s *")) + (setq-local comment-start comment) + (setq-local comment-start-skip + (concat (regexp-quote comment-start) "+\\s *")) (if font-lock - (set (make-local-variable 'font-lock-defaults) - `(,font-lock nil t nil nil)))) + (setq-local font-lock-defaults `(,font-lock nil t nil nil)))) ;;;###autoload (define-derived-mode conf-unix-mode conf-mode "Conf[Unix]" @@ -497,13 +486,11 @@ x.1 = x.2.y.1.z.1 = x.2.y.1.z.2.zz =" (conf-mode-initialize "#" 'conf-javaprop-font-lock-keywords) - (set (make-local-variable 'conf-assignment-column) - conf-javaprop-assignment-column) - (set (make-local-variable 'conf-assignment-regexp) - ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)") - (setq comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *") - (setq imenu-generic-expression - '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1)))) + (setq-local conf-assignment-column conf-javaprop-assignment-column) + (setq-local conf-assignment-regexp ".+?\\([ \t]*[=: \t][ \t]*\\|$\\)") + (setq-local comment-start-skip "\\(?:#+\\|/[/*]+\\)\\s *") + (setq-local imenu-generic-expression + '(("Parameters" "^[ \t]*\\(.+?\\)[=: \t]" 1)))) ;;;###autoload (define-derived-mode conf-space-mode conf-unix-mode "Conf[Space]" @@ -529,20 +516,18 @@ class desktop add /dev/audio desktop add /dev/mixer desktop" (conf-mode-initialize "#" 'conf-space-font-lock-keywords) - (make-local-variable 'conf-assignment-sign) - (setq conf-assignment-sign nil) - (make-local-variable 'conf-space-keywords) + (setq-local conf-assignment-sign nil) (cond (buffer-file-name ;; We set conf-space-keywords directly, but a value which is ;; in the local variables list or interactively specified ;; (see the function conf-space-keywords) takes precedence. - (setq conf-space-keywords - (assoc-default buffer-file-name conf-space-keywords-alist - 'string-match)))) + (setq-local conf-space-keywords + (assoc-default buffer-file-name conf-space-keywords-alist + #'string-match)))) (conf-space-mode-internal) ;; In case the local variables list specifies conf-space-keywords, ;; recompute other things from that afterward. - (add-hook 'hack-local-variables-hook 'conf-space-mode-internal nil t)) + (add-hook 'hack-local-variables-hook #'conf-space-mode-internal nil t)) ;;;###autoload (defun conf-space-keywords (keywords) @@ -553,16 +538,16 @@ See `conf-space-mode'." (conf-space-mode)) (if (string-equal keywords "") (setq keywords nil)) - (setq conf-space-keywords keywords) + (setq-local conf-space-keywords keywords) (conf-space-mode-internal) (run-mode-hooks)) (defun conf-space-mode-internal () - (make-local-variable 'conf-assignment-regexp) - (setq conf-assignment-regexp - (if conf-space-keywords - (concat "\\(?:" conf-space-keywords "\\)[ \t]+.+?\\([ \t]+\\|$\\)") - ".+?\\([ \t]+\\|$\\)")) + (setq-local conf-assignment-regexp + (if conf-space-keywords + (concat "\\(?:" conf-space-keywords + "\\)[ \t]+.+?\\([ \t]+\\|$\\)") + ".+?\\([ \t]+\\|$\\)")) ;; If Font Lock is already enabled, reenable it with new ;; conf-assignment-regexp. (when (and font-lock-mode @@ -596,17 +581,13 @@ For details see `conf-mode'. Example: <Multi_key> <exclam> <exclam> : \"\\241\" exclamdown <Multi_key> <c> <slash> : \"\\242\" cent" (conf-mode-initialize "#" 'conf-colon-font-lock-keywords) - (set (make-local-variable 'conf-assignment-space) - conf-colon-assignment-space) - (set (make-local-variable 'conf-assignment-column) - conf-colon-assignment-column) - (set (make-local-variable 'conf-assignment-sign) - ?:) - (set (make-local-variable 'conf-assignment-regexp) - ".+?\\([ \t]*:[ \t]*\\)") - (setq imenu-generic-expression - `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1) - ,@(cdr imenu-generic-expression)))) + (setq-local conf-assignment-space conf-colon-assignment-space) + (setq-local conf-assignment-column conf-colon-assignment-column) + (setq-local conf-assignment-sign ?:) + (setq-local conf-assignment-regexp ".+?\\([ \t]*:[ \t]*\\)") + (setq-local imenu-generic-expression + `(("Parameters" "^[ \t]*\\(.+?\\)[ \t]*:" 1) + ,@(cdr imenu-generic-expression)))) ;;;###autoload (define-derived-mode conf-ppd-mode conf-colon-mode "Conf[PPD]" diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index 0d4a910a1db..2cd99787e8a 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -119,7 +119,6 @@ ("cue" cue-before cue-after) ("cue-after" uri "none") ("cue-before" uri "none") - ("direction" "ltr" "rtl") ("display" "inline" "block" "list-item" "inline-block" "table" "inline-table" "table-row-group" "table-header-group" "table-footer-group" "table-row" "table-column-group" @@ -180,7 +179,6 @@ ("stress" number) ("table-layout" "auto" "fixed") ("top" length percentage "auto") - ("unicode-bidi" "normal" "embed" "bidi-override") ("vertical-align" "baseline" "sub" "super" "top" "text-top" "middle" "bottom" "text-bottom" percentage length) ("visibility" "visible" "hidden" "collapse") @@ -278,6 +276,10 @@ ("color" color) ("opacity" alphavalue) + ;; CSS Containment Module Level 1 + ;; (https://www.w3.org/TR/css-contain-1/#property-index) + ("contain" "none" "strict" "content" "size" "layout" "paint") + ;; CSS Grid Layout Module Level 1 ;; (https://www.w3.org/TR/css-grid-1/#property-index) ("grid" grid-template grid-template-rows "auto-flow" "dense" @@ -490,6 +492,16 @@ ;; (https://www.w3.org/TR/css-will-change-1/#property-index) ("will-change" "auto" animateable-feature) + ;; CSS Writing Modes Level 3 + ;; (https://www.w3.org/TR/css-writing-modes-3/#property-index) + ;; "glyph-orientation-vertical" is obsolete and left out. + ("direction" "ltr" "rtl") + ("text-combine-upright" "none" "all") + ("text-orientation" "mixed" "upright" "sideways") + ("unicode-bidi" "normal" "embed" "isolate" "bidi-override" + "isolate-override" "plaintext") + ("writing-mode" "horizontal-tb" "vertical-rl" "vertical-lr") + ;; Filter Effects Module Level 1 ;; (http://www.w3.org/TR/filter-effects/#property-index) ("color-interpolation-filters" "auto" "sRGB" "linearRGB") @@ -874,7 +886,7 @@ cannot be completed sensibly: `custom-ident', (defconst css-escapes-re "\\\\\\(?:[^\000-\037\177]\\|[[:xdigit:]]+[ \n\t\r\f]?\\)") -(defconst css-nmchar-re (concat "\\(?:[-[:alnum:]]\\|" css-escapes-re "\\)")) +(defconst css-nmchar-re (concat "\\(?:[-_[:alnum:]]\\|" css-escapes-re "\\)")) (defconst css-nmstart-re (concat "\\(?:[[:alpha:]]\\|" css-escapes-re "\\)")) (defconst css-ident-re ;; (concat css-nmstart-re css-nmchar-re "*") ;; Apparently, "at rules" names can start with a dash, e.g. @-moz-keyframes. @@ -1137,17 +1149,6 @@ returns, point will be at the end of the recognized color." ;; Evaluate to the color if the name is found. ((css--named-color start-point match)))) -(defun css--contrasty-color (name) - "Return a color that contrasts with NAME. -NAME is of any form accepted by `color-distance'. -The returned color will be usable by Emacs and will contrast -with NAME; in particular so that if NAME is used as a background -color, the returned color can be used as the foreground and still -be readable." - ;; See bug#25525 for a discussion of this. - (if (> (color-distance name "black") 292485) - "black" "white")) - (defcustom css-fontify-colors t "Whether CSS colors should be fontified using the color as the background. When non-`nil', a text representing CSS color will be fontified @@ -1187,7 +1188,8 @@ START and END are buffer positions." (add-text-properties start (point) (list 'face (list :background color - :foreground (css--contrasty-color color) + :foreground (readable-foreground-color + color) :box '(:line-width -1)))))))))))) extended-region)) diff --git a/lisp/textmodes/flyspell.el b/lisp/textmodes/flyspell.el index 4c24e70d1f7..39a1b488a74 100644 --- a/lisp/textmodes/flyspell.el +++ b/lisp/textmodes/flyspell.el @@ -89,7 +89,7 @@ EXCEPTION-LIST is a list of strings. The checked word is downcased before comparing with these exceptions." :group 'flyspell :type '(alist :key-type (choice (const :tag "All dictionaries" nil) - string) + regexp) :value-type (repeat string)) :version "24.1") @@ -234,7 +234,7 @@ Ispell's ultimate default dictionary." "A string that is the regular expression that matches TeX commands." :group 'flyspell :version "21.1" - :type 'string) + :type 'regexp) (defcustom flyspell-check-tex-math-command nil "Non-nil means check even inside TeX math environment. diff --git a/lisp/textmodes/mhtml-mode.el b/lisp/textmodes/mhtml-mode.el index b9161d9697e..54e20779bdc 100644 --- a/lisp/textmodes/mhtml-mode.el +++ b/lisp/textmodes/mhtml-mode.el @@ -73,7 +73,9 @@ code(); (defconst mhtml--crucial-variable-prefix (regexp-opt '("comment-" "uncomment-" "electric-indent-" - "smie-" "forward-sexp-function" "completion-" "major-mode")) + "smie-" "forward-sexp-function" "completion-" "major-mode" + "adaptive-fill-" "fill-" "normal-auto-fill-function" + "paragraph-")) "Regexp matching the prefix of \"crucial\" buffer-locals we want to capture.") (defconst mhtml--variable-prefix @@ -157,54 +159,6 @@ code(); (mhtml--submode-name submode) ""))) -(defvar font-lock-beg) -(defvar font-lock-end) - -(defun mhtml--extend-font-lock-region () - "Extend the font lock region according to HTML sub-mode needs. - -This is used via `font-lock-extend-region-functions'. It ensures -that the font-lock region is extended to cover either whole -lines, or to the spot where the submode changes, whichever is -smallest." - (let ((orig-beg font-lock-beg) - (orig-end font-lock-end)) - ;; The logic here may look odd but it is needed to ensure that we - ;; do the right thing when trying to limit the search. - (save-excursion - (goto-char font-lock-beg) - ;; previous-single-property-change starts by looking at the - ;; previous character, but we're trying to extend a region to - ;; include just characters with the same submode as this - ;; character. - (unless (eobp) - (forward-char)) - (setq font-lock-beg (previous-single-property-change - (point) 'mhtml-submode nil - (line-beginning-position))) - (unless (eq (get-text-property font-lock-beg 'mhtml-submode) - (get-text-property orig-beg 'mhtml-submode)) - (cl-incf font-lock-beg)) - - (goto-char font-lock-end) - (unless (bobp) - (backward-char)) - (setq font-lock-end (next-single-property-change - (point) 'mhtml-submode nil - (line-beginning-position 2))) - (unless (eq (get-text-property font-lock-end 'mhtml-submode) - (get-text-property orig-end 'mhtml-submode)) - (cl-decf font-lock-end))) - - ;; Also handle the multiline property -- but handle it here, and - ;; not via font-lock-extend-region-functions, to avoid the - ;; situation where the two extension functions disagree. - ;; See bug#29159. - (font-lock-extend-region-multiline) - - (or (/= font-lock-beg orig-beg) - (/= font-lock-end orig-end)))) - (defun mhtml--submode-fontify-one-region (submode beg end &optional loudly) (if submode (mhtml--with-locals submode @@ -303,17 +257,14 @@ This is used by `mhtml--pre-command'.") sgml-syntax-propertize-rules)) (defun mhtml-syntax-propertize (start end) - ;; First remove our special settings from the affected text. They - ;; will be re-applied as needed. - (remove-list-of-text-properties start end - '(syntax-table local-map mhtml-submode)) - (goto-char start) - ;; Be sure to look back one character, because START won't yet have - ;; been propertized. - (unless (bobp) - (let ((submode (get-text-property (1- (point)) 'mhtml-submode))) - (if submode - (mhtml--syntax-propertize-submode submode end)))) + (let ((submode (get-text-property start 'mhtml-submode))) + ;; First remove our special settings from the affected text. They + ;; will be re-applied as needed. + (remove-list-of-text-properties start end + '(syntax-table local-map mhtml-submode)) + (goto-char start) + (if submode + (mhtml--syntax-propertize-submode submode end))) (sgml-syntax-propertize (point) end mhtml--syntax-propertize)) (defun mhtml-indent-line () @@ -364,8 +315,6 @@ the rules from `css-mode'." (setq-local syntax-propertize-function #'mhtml-syntax-propertize) (setq-local font-lock-fontify-region-function #'mhtml--submode-fontify-region) - (setq-local font-lock-extend-region-functions - '(mhtml--extend-font-lock-region)) ;; Attach this to both pre- and post- hooks just in case it ever ;; changes a key binding that might be accessed from the menu bar. @@ -383,6 +332,18 @@ the rules from `css-mode'." ;: Hack (js--update-quick-match-re) + ;; Setup the appropriate js-mode value of auto-fill-function. + (setf (mhtml--submode-crucial-captured-locals mhtml--js-submode) + (push (cons 'auto-fill-function + (if (and (boundp 'auto-fill-function) auto-fill-function) + #'js-do-auto-fill + nil)) + (mhtml--submode-crucial-captured-locals mhtml--js-submode))) + + ;; This mode might be using CC Mode's filling functionality. + (c-foreign-init-lit-pos-cache) + (add-hook 'before-change-functions #'c-foreign-truncate-lit-pos-cache nil t) + ;; This is sort of a prog-mode as well as a text mode. (run-hooks 'prog-mode-hook)) diff --git a/lisp/textmodes/nroff-mode.el b/lisp/textmodes/nroff-mode.el index 62e8b1f0934..bb2582cf7a2 100644 --- a/lisp/textmodes/nroff-mode.el +++ b/lisp/textmodes/nroff-mode.el @@ -50,7 +50,6 @@ (let ((map (make-sparse-keymap)) (menu-map (make-sparse-keymap))) (define-key map "\t" 'tab-to-tab-stop) - (define-key map "\es" 'center-line) (define-key map "\e?" 'nroff-count-text-lines) (define-key map "\n" 'nroff-electric-newline) (define-key map "\en" 'nroff-forward-text-line) diff --git a/lisp/textmodes/paragraphs.el b/lisp/textmodes/paragraphs.el index 99c3e471241..e22e3f48994 100644 --- a/lisp/textmodes/paragraphs.el +++ b/lisp/textmodes/paragraphs.el @@ -168,7 +168,7 @@ to obtain the value of this variable." (defcustom sentence-end-base "[.?!…‽][]\"'”’)}»›]*" "Regexp matching the basic end of a sentence, not including following space." :group 'paragraphs - :type 'string + :type 'regexp :version "25.1") (put 'sentence-end-base 'safe-local-variable 'stringp) diff --git a/lisp/textmodes/po.el b/lisp/textmodes/po.el index d5645e86304..29c6d3f4608 100644 --- a/lisp/textmodes/po.el +++ b/lisp/textmodes/po.el @@ -1,4 +1,4 @@ -;;; po.el --- basic support of PO translation files +;;; po.el --- basic support of PO translation files -*- lexical-binding:t -*- ;; Copyright (C) 1995-1998, 2000-2020 Free Software Foundation, Inc. diff --git a/lisp/textmodes/reftex-vars.el b/lisp/textmodes/reftex-vars.el index ca92541331e..c9fd19d2324 100644 --- a/lisp/textmodes/reftex-vars.el +++ b/lisp/textmodes/reftex-vars.el @@ -925,7 +925,7 @@ DOWNCASE t: Downcase words before using them." "\\<label[[:space:]]*=[[:space:]]*" ;; Match the label value; braces around the value are ;; optional. - "{?\\(?1:[^] ,}\r\n\t%]+\\)}?" + "{?\\(?1:[^] ,}\r\n\t%]+\\)" ;; We are done. Just search until the next closing bracket "[^]]*\\]")) "List of regexps matching \\label definitions. @@ -2100,6 +2100,8 @@ construct: \\bbb [xxx] {aaa}." "Hook which is being run when loading reftex.el." :group 'reftex-miscellaneous-configurations :type 'hook) +(make-obsolete-variable 'reftex-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom reftex-mode-hook nil "Hook which is being run when turning on RefTeX mode." diff --git a/lisp/textmodes/reftex.el b/lisp/textmodes/reftex.el index 542f1fef14e..4071c0dd074 100644 --- a/lisp/textmodes/reftex.el +++ b/lisp/textmodes/reftex.el @@ -2371,7 +2371,7 @@ what in fact did happen. Check if the bug is reproducible with an up-to-date version of RefTeX available from https://www.gnu.org/software/auctex/. -If the bug is triggered by a specific \(La)TeX file, you should try +If the bug is triggered by a specific (La)TeX file, you should try to produce a minimal sample file showing the problem and include it in your report. diff --git a/lisp/textmodes/remember.el b/lisp/textmodes/remember.el index 836dfb4a538..279dbb4450c 100644 --- a/lisp/textmodes/remember.el +++ b/lisp/textmodes/remember.el @@ -5,7 +5,7 @@ ;; Author: John Wiegley <johnw@gnu.org> ;; Maintainer: emacs-devel@gnu.org ;; Created: 29 Mar 1999 -;; Version: 2.0 +;; Old-Version: 2.0 ;; Keywords: data memory todo pim ;; URL: http://gna.org/projects/remember-el/ @@ -181,6 +181,7 @@ (defconst remember-version "2.0" "This version of remember.") +(make-obsolete-variable 'remember-version nil "28.1") (defgroup remember nil "A mode to remember information." diff --git a/lisp/textmodes/sgml-mode.el b/lisp/textmodes/sgml-mode.el index 6152a8ad0a7..b5ff6a69671 100644 --- a/lisp/textmodes/sgml-mode.el +++ b/lisp/textmodes/sgml-mode.el @@ -286,7 +286,10 @@ separated by a space." (defconst sgml-namespace-re "[_[:alpha:]][-_.[:alnum:]]*") (defconst sgml-name-re "[_:[:alpha:]][-_.:[:alnum:]]*") (defconst sgml-tag-name-re (concat "<\\([!/?]?" sgml-name-re "\\)")) -(defconst sgml-attrs-re "\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*") +(defconst sgml-attrs-re + ;; This pattern cannot begin with a character matched by the end of + ;; `sgml-name-re' above. + "\\(?:[^_.:\"'/><[:alnum:]-]\\(?:[^\"'/><]\\|\"[^\"]*\"\\|'[^']*'\\)*\\)?") (defconst sgml-start-tag-regex (concat "<" sgml-name-re sgml-attrs-re) "Regular expression that matches a non-empty start tag. Any terminating `>' or `/' is not matched.") @@ -1849,8 +1852,8 @@ This takes effect when first loading the library.") "Keymap for commands for use in HTML mode.") (defvar html-face-tag-alist - '((bold . "b") - (italic . "i") + '((bold . "strong") + (italic . "em") (underline . "u") (mode-line . "rev")) "Value of `sgml-face-tag-alist' for HTML mode.") @@ -2360,7 +2363,7 @@ have <h1>Very Major Headlines</h1> through <h6>Very Minor Headlines</h6> <p>Paragraphs only need an opening tag. Line breaks and multiple spaces are ignored unless the text is <pre>preformatted.</pre> Text can be marked as -<b>bold</b>, <i>italic</i> or <u>underlined</u> using the normal M-o or +<strong>bold</strong>, <em>italic</em> or <u>underlined</u> using the normal M-o or Edit/Text Properties/Face commands. Pages can have <a name=\"SOMENAME\">named points</a> and can link other points diff --git a/lisp/textmodes/table.el b/lisp/textmodes/table.el index bd2cac7aebb..33f181b80c3 100644 --- a/lisp/textmodes/table.el +++ b/lisp/textmodes/table.el @@ -793,6 +793,8 @@ simply by any key input." "List of functions to be called after the table is first loaded." :type 'hook :group 'table-hooks) +(make-obsolete-variable 'table-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom table-point-entered-cell-hook nil "List of functions to be called after point entered a table cell." @@ -3207,11 +3209,7 @@ CALS (DocBook DTD): (while (and (re-search-forward "$" nil t) (not (eobp))) (insert "<br />") - (forward-char 1))) - (unless (and table-html-delegate-spacing-to-user-agent - (progn - (goto-char (point-min)) - (looking-at "\\s *\\'"))))) + (forward-char 1)))) ((eq language 'cals) (table--remove-eol-spaces (point-min) (point-max)) (if (re-search-forward "\\s +\\'" nil t) diff --git a/lisp/textmodes/tex-mode.el b/lisp/textmodes/tex-mode.el index 0e28756ea75..e3d5759579a 100644 --- a/lisp/textmodes/tex-mode.el +++ b/lisp/textmodes/tex-mode.el @@ -224,7 +224,7 @@ Should show the queue(s) that \\[tex-print] puts jobs on." :group 'tex-view) ;;;###autoload -(defcustom tex-default-mode 'latex-mode +(defcustom tex-default-mode #'latex-mode "Mode to enter for a new file that might be either TeX or LaTeX. This variable is used when it can't be determined whether the file is plain TeX or LaTeX or what because the file contains no commands. @@ -465,7 +465,7 @@ An alternative value is \" . \", if you use a font with a narrow period." ; ("{\\\\bf\\([^}]+\\)}" 1 'bold keep) ; ("{\\\\\\(em\\|it\\|sl\\)\\([^}]+\\)}" 2 'italic keep) ; ("\\\\\\([a-zA-Z@]+\\|.\\)" . font-lock-keyword-face) -; ("^[ \t\n]*\\\\def[\\\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep)) +; ("^[ \t\n]*\\\\def[\\@]\\(\\w+\\)" 1 font-lock-function-name-face keep)) ; ;; Rewritten and extended for LaTeX2e by Ulrik Dickow <dickow@nbi.dk>. ; '(("\\\\\\(begin\\|end\\|newcommand\\){\\([a-zA-Z0-9\\*]+\\)}" ; 2 font-lock-function-name-face) @@ -668,7 +668,9 @@ An alternative value is \" . \", if you use a font with a narrow period." "Default expressions to highlight in TeX modes.") (defvar tex-verbatim-environments - '("verbatim" "verbatim*")) + '("verbatim" "verbatim*" + "Verbatim" ;; From "fancyvrb" + )) (put 'tex-verbatim-environments 'safe-local-variable (lambda (x) (not (memq nil (mapcar #'stringp x))))) @@ -966,7 +968,7 @@ Inherits `shell-mode-map' with a few additions.") ;; This would be a lot simpler if we just used a regexp search, ;; but then it would be too slow. -(defun tex-guess-mode () +(defun tex--guess-mode () (let ((mode tex-default-mode) slash comment) (save-excursion (goto-char (point-min)) @@ -983,52 +985,40 @@ Inherits `shell-mode-map' with a few additions.") (regexp-opt '("documentstyle" "documentclass" "begin" "subsection" "section" "part" "chapter" "newcommand" - "renewcommand" "RequirePackage") 'words) + "renewcommand" "RequirePackage") + 'words) "\\|NeedsTeXFormat{LaTeX"))) (if (and (looking-at "document\\(style\\|class\\)\\(\\[.*\\]\\)?{slides}") ;; SliTeX is almost never used any more nowadays. (tex-executable-exists-p slitex-run-command)) - 'slitex-mode - 'latex-mode) - 'plain-tex-mode)))) - (funcall mode))) + #'slitex-mode + #'latex-mode) + #'plain-tex-mode)))) + mode)) ;; `tex-mode' plays two roles: it's the parent of several sub-modes ;; but it's also the function that chooses between those submodes. ;; To tell the difference between those two cases where the function ;; might be called, we check `delay-mode-hooks'. -(define-derived-mode tex-mode text-mode "generic-TeX" - (tex-common-initialization)) -;; We now move the function and define it again. This gives a warning -;; in the byte-compiler :-( but it's difficult to avoid because -;; `define-derived-mode' will necessarily define the function once -;; and we need to define it a second time for `autoload' to get the -;; proper docstring. -(defalias 'tex-mode-internal (symbol-function 'tex-mode)) - -;; Suppress the byte-compiler warning about multiple definitions. -;; This is a) ugly, and b) cheating, but this was the last -;; remaining warning from byte-compiling all of Emacs... -(eval-when-compile - (if (boundp 'byte-compile-function-environment) - (setq byte-compile-function-environment - (delq (assq 'tex-mode byte-compile-function-environment) - byte-compile-function-environment)))) - ;;;###autoload -(defun tex-mode () +(define-derived-mode tex-mode text-mode "generic-TeX" "Major mode for editing files of input for TeX, LaTeX, or SliTeX. +This is the shared parent mode of several submodes. Tries to determine (by looking at the beginning of the file) whether this file is for plain TeX, LaTeX, or SliTeX and calls `plain-tex-mode', -`latex-mode', or `slitex-mode', respectively. If it cannot be determined, +`latex-mode', or `slitex-mode', accordingly. If it cannot be determined, such as if there are no commands in the file, the value of `tex-default-mode' says which mode to use." - (interactive) - (if delay-mode-hooks - ;; We're called from one of the children already. - (tex-mode-internal) - (tex-guess-mode))) + (tex-common-initialization)) + +(advice-add 'tex-mode :around #'tex--redirect-to-submode) +(defun tex--redirect-to-submode (orig-fun) + "Redirect to one of the submodes when called directly." + (funcall (if delay-mode-hooks + ;; We're called from one of the children already. + orig-fun + (tex--guess-mode)))) ;; The following three autoloaded aliases appear to conflict with ;; AUCTeX. However, even though AUCTeX uses the mixed case variants @@ -1037,6 +1027,10 @@ says which mode to use." ;; AUCTeX to provide a fully functional user-level replacement. So ;; these aliases should remain as they are, in particular since AUCTeX ;; users are likely to use them. +;; Note from Stef: I don't understand the above explanation, the only +;; justification I can find to keep those confusing aliases is for those +;; users who may have files annotated with -*- LaTeX -*- (e.g. because they +;; received them from someone using AUCTeX). ;;;###autoload (defalias 'TeX-mode 'tex-mode) @@ -1252,10 +1246,10 @@ Entering SliTeX mode runs the hook `text-mode-hook', then the hook ("\\\\[a-zA-Z]+\\( +\\|{}\\)[a-zA-Z]*" . "") ("%" . "$")))) ;; A line containing just $$ is treated as a paragraph separator. - (setq-local paragraph-start "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$") + (setq-local paragraph-start "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$") ;; A line starting with $$ starts a paragraph, ;; but does not separate paragraphs if it has more stuff on it. - (setq-local paragraph-separate "[ \t]*$\\|[\f\\\\%]\\|[ \t]*\\$\\$[ \t]*$") + (setq-local paragraph-separate "[ \t]*$\\|[\f\\%]\\|[ \t]*\\$\\$[ \t]*$") (setq-local add-log-current-defun-function #'tex-current-defun-name) (setq-local comment-start "%") (setq-local comment-add 1) @@ -2301,9 +2295,6 @@ FILE is typically the output DVI or PDF file." (setq uptodate nil))))) uptodate))) - -(autoload 'format-spec "format-spec") - (defvar tex-executable-cache nil) (defun tex-executable-exists-p (name) "Like `executable-find' but with a cache." diff --git a/lisp/textmodes/texinfo.el b/lisp/textmodes/texinfo.el index 438cb7798a1..66378cb3468 100644 --- a/lisp/textmodes/texinfo.el +++ b/lisp/textmodes/texinfo.el @@ -958,6 +958,12 @@ to jump to the corresponding spot in the Texinfo source file." :type 'string :group 'texinfo) +(defcustom texinfo-texi2dvi-options "" + "Command line options for `texinfo-texi2dvi-command'." + :type 'string + :group 'texinfo + :version "28.1") + (defcustom texinfo-tex-command "tex" "Command used by `texinfo-tex-region' to run TeX on a region." :type 'string @@ -1002,9 +1008,10 @@ The value of `texinfo-tex-trailer' is appended to the temporary file after the r (interactive) (require 'tex-mode) (let ((tex-command texinfo-texi2dvi-command) - ;; Disable tex-start-options-string. texi2dvi would not - ;; understand anything specified here. - (tex-start-options-string "")) + (tex-start-options texinfo-texi2dvi-options) + ;; Disable tex-start-commands. texi2dvi would not understand + ;; anything specified here. + (tex-start-commands "")) (tex-buffer))) (defun texinfo-texindex () diff --git a/lisp/textmodes/tildify.el b/lisp/textmodes/tildify.el index 25f37ffa23d..398f7fdc232 100644 --- a/lisp/textmodes/tildify.el +++ b/lisp/textmodes/tildify.el @@ -67,7 +67,7 @@ matching the white space). The pattern is matched case-sensitive regardless of the value of `case-fold-search' setting." :version "25.1" :group 'tildify - :type 'string + :type 'regexp :safe t) (defcustom tildify-pattern-alist () @@ -417,7 +417,7 @@ of a space at point. The regexp is always case sensitive, regardless of the current `case-fold-search' setting." :version "25.1" :group 'tildify - :type 'string) + :type 'regexp) (defcustom tildify-space-predicates '(tildify-space-region-predicate) "A list of predicate functions for `tildify-space' function." diff --git a/lisp/thread.el b/lisp/thread.el index d40d7bed538..00a0084f81f 100644 --- a/lisp/thread.el +++ b/lisp/thread.el @@ -43,8 +43,6 @@ An EVENT has the format (err (cddr event))) (message "Error %s: %S" thread err)))) -(make-obsolete 'thread-alive-p 'thread-live-p "27.1") - ;;; The thread list buffer and list-threads command (defcustom thread-list-refresh-seconds 0.5 diff --git a/lisp/url/url-about.el b/lisp/url/url-about.el index dde47e94de5..5fe817cc0e8 100644 --- a/lisp/url/url-about.el +++ b/lisp/url/url-about.el @@ -51,7 +51,7 @@ " <title>Supported Protocols</title>\n" " </head>\n" " <body>\n" - " <h1>Supported Protocols - URL v" url-version "</h1>\n" + " <h1>Supported Protocols - URL package in Emacs " emacs-version "</h1>\n" " <table width='100%' border='1'>\n" " <tr>\n" " <td>Protocol\n" diff --git a/lisp/url/url-expand.el b/lisp/url/url-expand.el index 47964b081f4..f34ef810c4a 100644 --- a/lisp/url/url-expand.el +++ b/lisp/url/url-expand.el @@ -92,12 +92,19 @@ path components followed by `..' are removed, along with the `..' itself." (cond ((= (length url) 0) ; nil or empty string (url-recreate-url default)) - ((string-match url-nonrelative-link url) ; Fully-qualified URL, return it immediately + ((string-match url-nonrelative-link url) ; Fully-qualified URL, + ; return it immediately url) (t (let* ((urlobj (url-generic-parse-url url)) (inhibit-file-name-handlers t) - (expander (url-scheme-get-property (url-type default) 'expand-file-name))) + (expander (if (url-type default) + (url-scheme-get-property (url-type default) + 'expand-file-name) + ;; If neither the default nor the URL to be + ;; expanded have a protocol, then just use the + ;; identity expander as a fallback. + 'url-identity-expander))) (if (string-match "^//" url) (setq urlobj (url-generic-parse-url (concat (url-type default) ":" url)))) diff --git a/lisp/url/url-gw.el b/lisp/url/url-gw.el index bcb67431aa8..f16fc234025 100644 --- a/lisp/url/url-gw.el +++ b/lisp/url/url-gw.el @@ -191,7 +191,7 @@ linked Emacs under SunOS 4.x." proc (concat (mapconcat 'identity (append url-gateway-telnet-parameters (list host service)) " ") "\n")) - (url-wait-for-string "^\r*Escape character.*\r*\n+" proc) + (url-wait-for-string "^\r*Escape character.*\n+" proc) (delete-region (point-min) (match-end 0)) (process-send-string proc "\^]\n") (url-wait-for-string "^telnet" proc) diff --git a/lisp/url/url-http.el b/lisp/url/url-http.el index 55953c83c04..8532da1d1fb 100644 --- a/lisp/url/url-http.el +++ b/lisp/url/url-http.el @@ -225,7 +225,7 @@ request.") (os-info (unless (and (listp url-privacy-level) (memq 'os url-privacy-level)) (format "(%s; %s)" url-system-type url-os-type))) - (url-info (format "URL/%s" url-version))) + (url-info (format "URL/Emacs"))) (string-join (delq nil (list package-info url-info emacs-info os-info)) " "))) @@ -702,15 +702,7 @@ should be shown to the user." ;; Treat everything like '300' nil)) (when redirect-uri - ;; Clean off any whitespace and/or <...> cruft. - (if (string-match "\\([^ \t]+\\)[ \t]" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - (if (string-match "^<\\(.*\\)>$" redirect-uri) - (setq redirect-uri (match-string 1 redirect-uri))) - - ;; Some stupid sites (like sourceforge) send a - ;; non-fully-qualified URL (ie: /), which royally confuses - ;; the URL library. + ;; Handle relative redirect URIs. (if (not (string-match url-nonrelative-link redirect-uri)) ;; Be careful to use the real target URL, otherwise we may ;; compute the redirection relative to the URL of the proxy. @@ -1404,13 +1396,22 @@ The return value of this function is the retrieval buffer." (defun url-https-proxy-connect (connection) (setq url-http-after-change-function 'url-https-proxy-after-change-function) - (process-send-string connection (format (concat "CONNECT %s:%d HTTP/1.1\r\n" - "Host: %s\r\n" - "\r\n") - (url-host url-current-object) - (or (url-port url-current-object) - url-https-default-port) - (url-host url-current-object)))) + (process-send-string + connection + (format + (concat "CONNECT %s:%d HTTP/1.1\r\n" + "Host: %s\r\n" + (let ((proxy-auth (let ((url-basic-auth-storage + 'url-http-proxy-basic-auth-storage)) + (url-get-authentication url-http-proxy nil + 'any nil)))) + (and proxy-auth + (concat "Proxy-Authorization: " proxy-auth "\r\n"))) + "\r\n") + (url-host url-current-object) + (or (url-port url-current-object) + url-https-default-port) + (url-host url-current-object)))) (defun url-https-proxy-after-change-function (_st _nd _length) (let* ((process-buffer (current-buffer)) diff --git a/lisp/url/url-news.el b/lisp/url/url-news.el index d47eb02db68..9ef17cccd77 100644 --- a/lisp/url/url-news.el +++ b/lisp/url/url-news.el @@ -75,7 +75,7 @@ " </div>\n" " </body>\n" "</html>\n" - "<!-- Automatically generated by URL v" url-version " -->\n" + "<!-- Automatically generated by URL in Emacs " emacs-version " -->\n" ))) buf)) diff --git a/lisp/url/url-queue.el b/lisp/url/url-queue.el index ff18cf1fe40..46cdff0f724 100644 --- a/lisp/url/url-queue.el +++ b/lisp/url/url-queue.el @@ -123,17 +123,24 @@ The variable `url-queue-timeout' sets a timeout." (setq url-queue-progress-timer nil)))) (defun url-queue-callback-function (status job) - (setq url-queue (delq job url-queue)) - (when (and (eq (car status) :error) - (eq (cadr (cadr status)) 'connection-failed)) - ;; If we get a connection error, then flush all other jobs from - ;; the host from the queue. This particularly makes sense if the - ;; error really is a DNS resolver issue, which happens - ;; synchronously and totally halts Emacs. - (url-queue-remove-jobs-from-host - (plist-get (nthcdr 3 (cadr status)) :host))) - (url-queue-run-queue) - (apply (url-queue-callback job) (cons status (url-queue-cbargs job)))) + (let ((buffer (current-buffer))) + (setq url-queue (delq job url-queue)) + (when (and (eq (car status) :error) + (eq (cadr (cadr status)) 'connection-failed)) + ;; If we get a connection error, then flush all other jobs from + ;; the host from the queue. This particularly makes sense if the + ;; error really is a DNS resolver issue, which happens + ;; synchronously and totally halts Emacs. + (url-queue-remove-jobs-from-host + (plist-get (nthcdr 3 (cadr status)) :host))) + (url-queue-run-queue) + ;; Somehow something deep in the bowels in the URL library may + ;; have killed off the current buffer. So check that it's still + ;; alive before doing anything, and if not, just create a dummy + ;; buffer and do the callback anyway. + (unless (buffer-live-p buffer) + (set-buffer (generate-new-buffer " *temp*"))) + (apply (url-queue-callback job) (cons status (url-queue-cbargs job))))) (defun url-queue-remove-jobs-from-host (host) (let ((jobs nil)) diff --git a/lisp/url/url-util.el b/lisp/url/url-util.el index 645011a5783..6dd7a9c2aac 100644 --- a/lisp/url/url-util.el +++ b/lisp/url/url-util.el @@ -615,9 +615,7 @@ Creates FILE and its parent directories if they do not exist." (with-temp-buffer (write-region (point-min) (point-max) file nil 'silent nil 'excl))) (file-already-exists - (if (file-symlink-p file) - (error "Danger: `%s' is a symbolic link" file)) - (set-file-modes file #o0600)))) + (set-file-modes file #o0600 'nofollow)))) (autoload 'puny-encode-domain "puny") (autoload 'url-domsuf-cookie-allowed-p "url-domsuf") diff --git a/lisp/url/url-vars.el b/lisp/url/url-vars.el index 82617b76a71..d9277cf6f42 100644 --- a/lisp/url/url-vars.el +++ b/lisp/url/url-vars.el @@ -24,6 +24,7 @@ (defconst url-version "Emacs" "Version number of URL package.") +(make-obsolete-variable 'url-version nil "28.1") (defgroup url nil "Uniform Resource Locator tool." @@ -430,6 +431,8 @@ Should be one of: "Hook run after initializing the URL library." :group 'url :type 'hook) +(make-obsolete-variable 'url-load-hook + "use `with-eval-after-load' instead." "28.1") (defconst url-working-buffer " *url-work") diff --git a/lisp/url/url.el b/lisp/url/url.el index 12a8a9c2e21..321e79c019f 100644 --- a/lisp/url/url.el +++ b/lisp/url/url.el @@ -238,7 +238,8 @@ how long to wait for a response before giving up." (let ((retrieval-done nil) (start-time (current-time)) (url-asynchronous nil) - (asynch-buffer nil)) + (asynch-buffer nil) + (timed-out nil)) (setq asynch-buffer (url-retrieve url (lambda (&rest ignored) (url-debug 'retrieval "Synchronous fetching done (%S)" (current-buffer)) @@ -261,7 +262,9 @@ how long to wait for a response before giving up." ;; process output. (while (and (not retrieval-done) (or (not timeout) - (time-less-p (time-since start-time) timeout))) + (not (setq timed-out + (time-less-p timeout + (time-since start-time)))))) (url-debug 'retrieval "Spinning in url-retrieve-synchronously: %S (%S)" retrieval-done asynch-buffer) @@ -300,8 +303,16 @@ how long to wait for a response before giving up." (when quit-flag (delete-process proc)) (setq proc (and (not quit-flag) - (get-buffer-process asynch-buffer))))))) - asynch-buffer))) + (get-buffer-process asynch-buffer)))))) + ;; On timeouts, make sure we kill any pending processes. + ;; There may be more than one if we had a redirect. + (when timed-out + (when (process-live-p proc) + (delete-process proc)) + (when-let ((aproc (get-buffer-process asynch-buffer))) + (when (process-live-p aproc) + (delete-process aproc)))))) + asynch-buffer)) ;; url-mm-callback called from url-mm, which requires mm-decode. (declare-function mm-dissect-buffer "mm-decode" diff --git a/lisp/vc/diff-mode.el b/lisp/vc/diff-mode.el index 8171a585158..d194d6c0a0e 100644 --- a/lisp/vc/diff-mode.el +++ b/lisp/vc/diff-mode.el @@ -484,7 +484,7 @@ and the face `diff-added' for added lines.") ;; Prefer second name as first is most likely to be a backup or ;; version-control name. The [\t\n] at the end of the unidiff pattern ;; catches Debian source diff files (which lack the trailing date). - '((nil "\\+\\+\\+\\ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs + '((nil "\\+\\+\\+ \\([^\t\n]+\\)[\t\n]" 1) ; unidiffs (nil "^--- \\([^\t\n]+\\)\t.*\n\\*" 1))) ; context diffs ;;;; @@ -2720,7 +2720,9 @@ hunk text is not found in the source file." ;; When initialization is requested, we should be in a brand new ;; temp buffer. (cl-assert (null buffer-file-name)) - (let ((enable-local-variables :safe) ;; to find `mode:' + ;; Use `:safe' to find `mode:'. In case of hunk-only, use nil because + ;; Local Variables list might be incomplete when context is truncated. + (let ((enable-local-variables (unless hunk-only :safe)) (buffer-file-name file)) ;; Don't run hooks that might assume buffer-file-name ;; really associates buffer with a file (bug#39190). diff --git a/lisp/vc/ediff-init.el b/lisp/vc/ediff-init.el index fb1f25b6c6d..da6509b7cbe 100644 --- a/lisp/vc/ediff-init.el +++ b/lisp/vc/ediff-init.el @@ -452,6 +452,8 @@ For each buffer, the hooks are run with that buffer made current." "Hook run after Ediff is loaded. Can be used to change defaults." :type 'hook :group 'ediff-hook) +(make-obsolete-variable 'ediff-load-hook + "use `with-eval-after-load' instead." "28.1") (defcustom ediff-mode-hook nil "Hook run just after ediff-mode is set up in the control buffer. @@ -1255,22 +1257,8 @@ Instead, C-h would jump to previous difference." :type 'boolean :group 'ediff) -;; This is the same as temporary-file-directory from Emacs 20.3. -;; Copied over here because XEmacs doesn't have this variable. -(defcustom ediff-temp-file-prefix - (file-name-as-directory - (cond ((boundp 'temporary-file-directory) temporary-file-directory) - ((fboundp 'temp-directory) (temp-directory)) - (t "/tmp/"))) -;;; (file-name-as-directory -;;; (cond ((memq system-type '(ms-dos windows-nt)) -;;; (or (getenv "TEMP") (getenv "TMPDIR") (getenv "TMP") "c:/temp")) -;;; (t -;;; (or (getenv "TMPDIR") (getenv "TMP") (getenv "TEMP") "/tmp")))) - "Prefix to put on Ediff temporary file names. -Do not start with `~/' or `~USERNAME/'." - :type 'string - :group 'ediff) +(define-obsolete-variable-alias 'ediff-temp-file-prefix + 'temporary-file-directory "28.1") (defcustom ediff-temp-file-mode 384 ; u=rw only "Mode for Ediff temporary files." @@ -1282,11 +1270,11 @@ Do not start with `~/' or `~USERNAME/'." (defcustom ediff-metachars "[ \t\n!\"#$&'()*;<=>?[\\^`{|~]" "Regexp that matches characters that must be quoted with `\\' in shell command line. This default should work without changes." - :type 'string + :type 'regexp :group 'ediff) -;; needed to simulate frame-char-width in XEmacs. -(defvar ediff-H-glyph (if (featurep 'xemacs) (make-glyph "H"))) +(defvar ediff-H-glyph nil) +(make-obsolete-variable 'ediff-H-glyph nil "28.1") ;; Temporary file used for refining difference regions in buffer A. @@ -1522,16 +1510,6 @@ This default should work without changes." (setq dir (substring dir 0 pos))) (ediff-abbreviate-file-name (file-name-directory dir)))) -(defun ediff-truncate-string-left (str newlen) - ;; leave space for ... on the left - (let ((len (length str)) - substr) - (if (<= len newlen) - str - (setq newlen (max 0 (- newlen 3))) - (setq substr (substring str (max 0 (- len 1 newlen)))) - (concat "..." substr)))) - (defsubst ediff-nonempty-string-p (string) (and (stringp string) (not (string= string "")))) diff --git a/lisp/vc/ediff-mult.el b/lisp/vc/ediff-mult.el index fee87e8352e..2b1b07927f8 100644 --- a/lisp/vc/ediff-mult.el +++ b/lisp/vc/ediff-mult.el @@ -113,7 +113,6 @@ (require 'ediff-wind) (require 'ediff-util) - ;; meta-buffer (ediff-defvar-local ediff-meta-buffer nil "") (ediff-defvar-local ediff-parent-meta-buffer nil "") @@ -1172,7 +1171,7 @@ behavior." ;; abbreviate the file name, if file exists (if (and (not (stringp fname)) (< file-size -1)) "-------" ; file doesn't exist - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name fname) max-filename-width))))))) @@ -1266,7 +1265,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code1) 0) ; dir1 (let ((beg (point))) (insert (format "%-27s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir1 file)) (file-name-as-directory file) @@ -1281,7 +1280,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code2) 0) ; dir2 (let ((beg (point))) (insert (format "%-26s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir2 file)) (file-name-as-directory file) @@ -1295,7 +1294,7 @@ Useful commands: (if (= (mod membership-code ediff-membership-code3) 0) ; dir3 (let ((beg (point))) (insert (format " %-25s" - (ediff-truncate-string-left + (string-truncate-left (ediff-abbreviate-file-name (if (file-directory-p (concat dir3 file)) (file-name-as-directory file) diff --git a/lisp/vc/ediff-ptch.el b/lisp/vc/ediff-ptch.el index cb0ae6ff6e1..f6af5a45550 100644 --- a/lisp/vc/ediff-ptch.el +++ b/lisp/vc/ediff-ptch.el @@ -119,7 +119,7 @@ patch. So, don't change these variables, unless the default doesn't work." (defcustom ediff-context-diff-label-regexp (let ((stuff "\\([^ \t\n]+\\)")) (concat "\\(" ; context diff 2-liner - "^\\*\\*\\* +" stuff "[^*]+[\t ]*\n--- +" stuff + "^\\*\\*\\* +" stuff "[^*]+\n--- +" stuff "\\|" ; unified format diff 2-liner "^--- +" stuff ".*\n\\+\\+\\+ +" stuff "\\)")) diff --git a/lisp/vc/ediff-util.el b/lisp/vc/ediff-util.el index a8af9ba37a2..4a84c1ecd9c 100644 --- a/lisp/vc/ediff-util.el +++ b/lisp/vc/ediff-util.el @@ -131,7 +131,6 @@ to invocation.") (define-key ediff-mode-map [delete] 'ediff-previous-difference) (define-key ediff-mode-map "\C-h" (if ediff-no-emacs-help-in-control-buffer 'ediff-previous-difference nil)) - ;; must come after C-h, or else C-h wipes out backspace's binding in XEmacs (define-key ediff-mode-map [backspace] 'ediff-previous-difference) (define-key ediff-mode-map [?\S-\ ] 'ediff-previous-difference) (define-key ediff-mode-map "n" 'ediff-next-difference) @@ -1540,10 +1539,10 @@ the width of the A/B/C windows." ;; hscrolling. (if (= last-command-event ?<) (lambda (arg) - (let ((prefix-arg arg)) + (let ((current-prefix-arg arg)) (call-interactively #'scroll-left))) (lambda (arg) - (let ((prefix-arg arg)) + (let ((current-prefix-arg arg)) (call-interactively #'scroll-right)))) ;; calculate argument to scroll-left/right ;; if there is an explicit argument @@ -3144,8 +3143,8 @@ Hit \\[ediff-recenter] to reset the windows afterward." (> (length p) 2)) (setq short-p (substring p 0 2))) - (setq f (concat ediff-temp-file-prefix p) - short-f (concat ediff-temp-file-prefix short-p) + (setq f (concat temporary-file-directory p) + short-f (concat temporary-file-directory short-p) f (cond (given-file) ((find-file-name-handler f 'insert-file-contents) ;; to thwart file name handlers in write-region, @@ -3449,7 +3448,6 @@ Without an argument, it saves customized diff argument, if available (declare-function ediff-regions-internal "ediff" (buffer-a beg-a end-a buffer-b beg-b end-b startup-hooks job-name word-mode setup-parameters)) -(defvar zmacs-regions) ;;XEmacs'ism. (defun ediff-inferior-compare-regions () "Compare regions in an active Ediff session. @@ -3461,7 +3459,6 @@ Ediff Control Panel to restore highlighting." (interactive) (let ((answer "") (possibilities (list ?A ?B ?C)) - (zmacs-regions t) use-current-diff-p begA begB endA endB bufA bufB) diff --git a/lisp/vc/ediff-vers.el b/lisp/vc/ediff-vers.el index a95606fad5e..4ee7ee5c1f5 100644 --- a/lisp/vc/ediff-vers.el +++ b/lisp/vc/ediff-vers.el @@ -49,15 +49,10 @@ comparison or merge operations are being performed." :group 'ediff-vers ) -(defalias 'ediff-vc-revision-other-window - (if (fboundp 'vc-revision-other-window) - 'vc-revision-other-window - 'vc-version-other-window)) - -(defalias 'ediff-vc-working-revision - (if (fboundp 'vc-working-revision) - 'vc-working-revision - 'vc-workfile-version)) +(define-obsolete-function-alias 'ediff-vc-revision-other-window + #'vc-revision-other-window "28.1") +(define-obsolete-function-alias 'ediff-vc-working-revision + #'vc-working-revision "28.1") ;; VC.el support @@ -88,12 +83,12 @@ comparison or merge operations are being performed." (setq rev1 (ediff-vc-latest-version (buffer-file-name)))) (save-window-excursion (save-excursion - (ediff-vc-revision-other-window rev1) + (vc-revision-other-window rev1) (setq rev1buf (current-buffer) file1 (buffer-file-name))) (save-excursion (or (string= rev2 "") ; use current buffer - (ediff-vc-revision-other-window rev2)) + (vc-revision-other-window rev2)) (setq rev2buf (current-buffer) file2 (buffer-file-name))) (push (lambda () @@ -165,18 +160,18 @@ comparison or merge operations are being performed." (let (buf1 buf2 ancestor-buf) (save-window-excursion (save-excursion - (ediff-vc-revision-other-window rev1) + (vc-revision-other-window rev1) (setq buf1 (current-buffer))) (save-excursion (or (string= rev2 "") - (ediff-vc-revision-other-window rev2)) + (vc-revision-other-window rev2)) (setq buf2 (current-buffer))) (if ancestor-rev (save-excursion (if (string= ancestor-rev "") - (setq ancestor-rev (ediff-vc-working-revision + (setq ancestor-rev (vc-working-revision buffer-file-name))) - (ediff-vc-revision-other-window ancestor-rev) + (vc-revision-other-window ancestor-rev) (setq ancestor-buf (current-buffer)))) (push (let ((f1 (buffer-file-name buf1)) (f2 (unless (string= rev2 "") (buffer-file-name buf2))) diff --git a/lisp/vc/ediff-wind.el b/lisp/vc/ediff-wind.el index 7b2e1109c87..a23d72070ab 100644 --- a/lisp/vc/ediff-wind.el +++ b/lisp/vc/ediff-wind.el @@ -156,12 +156,10 @@ In this case, Ediff will use those frames to display these buffers." '(name . "Ediff") ;;'(unsplittable . t) '(minibuffer . nil) - '(user-position . t) ; Emacs only - '(vertical-scroll-bars . nil) ; Emacs only - '(scrollbar-width . 0) ; XEmacs only - '(scrollbar-height . 0) ; XEmacs only - '(menu-bar-lines . 0) ; Emacs only - '(tool-bar-lines . 0) ; Emacs 21+ only + '(user-position . t) + '(vertical-scroll-bars . nil) + '(menu-bar-lines . 0) + '(tool-bar-lines . 0) '(left-fringe . 0) '(right-fringe . 0) ;; don't lower but auto-raise @@ -260,10 +258,9 @@ the frame used for the wide display.") This has effect only on a windowing system. If t, hitting `?' to toggle control panel off iconifies it. -This is only useful in Emacs and only for certain kinds of window managers, -such as TWM and its derivatives, since the window manager must permit -keyboard input to go into icons. XEmacs completely ignores keyboard input -into icons, regardless of the window manager." +This is only useful for certain kinds of window managers, such as +TWM and its derivatives, since the window manager must permit +keyboard input to go into icons." :type 'boolean) ;;; Functions @@ -952,8 +949,7 @@ create a new splittable frame if none is found." ;; just a precaution--we should be in ctl-buffer already (with-current-buffer ctl-buffer (make-local-variable 'frame-title-format) - (make-local-variable 'frame-icon-title-format) ; XEmacs - (make-local-variable 'icon-title-format)) ; Emacs + (make-local-variable 'icon-title-format)) (ediff-setup-control-buffer ctl-buffer) (setq dont-iconify-ctl-frame @@ -1098,6 +1094,7 @@ create a new splittable frame if none is found." ))) (defun ediff-xemacs-select-frame-hook () + (declare (obsolete nil "28.1")) (if (and (equal (selected-frame) ediff-control-frame) (not ediff-use-long-help-message)) (raise-frame ediff-control-frame))) diff --git a/lisp/vc/pcvs-parse.el b/lisp/vc/pcvs-parse.el index 466c621311f..dd56aec94a0 100644 --- a/lisp/vc/pcvs-parse.el +++ b/lisp/vc/pcvs-parse.el @@ -472,7 +472,7 @@ The remaining KEYS are passed directly to `cvs-create-fileinfo'." ;; Let's not get all worked up if the format changes a bit (cvs-match " *Working revision:.*$")) (cvs-or - (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\)[ \t]*.*$" (head-rev 1)) + (cvs-match " *RCS Version:[ \t]*\\([0-9.]+\\).*$" (head-rev 1)) (cvs-match " *Repository revision:[ \t]*\\([0-9.]+\\)[ \t]*\\(.*\\)$" (head-rev 1)) (cvs-match " *Repository revision:.*")) diff --git a/lisp/vc/smerge-mode.el b/lisp/vc/smerge-mode.el index 85868b91ecc..d0a83fd7c49 100644 --- a/lisp/vc/smerge-mode.el +++ b/lisp/vc/smerge-mode.el @@ -1429,15 +1429,16 @@ with a \\[universal-argument] prefix, makes up a 3-way conflict." (smerge-remove-props (point-min) (point-max)))) ;;;###autoload -(defun smerge-start-session () +(defun smerge-start-session (&optional interactively) "Turn on `smerge-mode' and move point to first conflict marker. If no conflict maker is found, turn off `smerge-mode'." - (interactive) - (smerge-mode 1) - (condition-case nil - (unless (looking-at smerge-begin-re) - (smerge-next)) - (error (smerge-auto-leave)))) + (interactive "p") + (when (or (null smerge-mode) interactively) + (smerge-mode 1) + (condition-case nil + (unless (looking-at smerge-begin-re) + (smerge-next)) + (error (smerge-auto-leave))))) (defcustom smerge-change-buffer-confirm t "If non-nil, request confirmation before moving to another buffer." diff --git a/lisp/vc/vc-bzr.el b/lisp/vc/vc-bzr.el index e5d307e7ede..f98730ed221 100644 --- a/lisp/vc/vc-bzr.el +++ b/lisp/vc/vc-bzr.el @@ -1316,6 +1316,15 @@ stream. Standard error output is discarded." vc-bzr-revision-keywords)) string pred))))) +(defun vc-bzr-repository-url (file-or-dir &optional _remote-name) + (let ((default-directory (vc-bzr-root file-or-dir))) + (with-temp-buffer + (vc-bzr-command "info" (current-buffer) 0 nil) + (goto-char (point-min)) + (if (re-search-forward "parent branch: \\(.*\\)$" nil t) + (match-string 1) + (error "Cannot determine Bzr repository URL"))))) + (provide 'vc-bzr) ;;; vc-bzr.el ends here diff --git a/lisp/vc/vc-dir.el b/lisp/vc/vc-dir.el index 38b4937e854..cdf8ab984e8 100644 --- a/lisp/vc/vc-dir.el +++ b/lisp/vc/vc-dir.el @@ -147,6 +147,12 @@ See `run-hooks'." '(menu-item "Unmark Previous " vc-dir-unmark-file-up :help "Move to the previous line and unmark the file")) + (define-key map [mark-unregistered] + '(menu-item "Mark Unregistered" vc-dir-mark-unregistered-files + :help "Mark all files in the unregistered state")) + (define-key map [mark-registered] + '(menu-item "Mark Registered" vc-dir-mark-registered-files + :help "Mark all files in the state edited, added or removed")) (define-key map [mark-all] '(menu-item "Mark All" vc-dir-mark-all-files :help "Mark all files that are in the same state as the current file\ @@ -310,6 +316,10 @@ See `run-hooks'." (define-key branch-map "l" 'vc-print-branch-log) (define-key branch-map "s" 'vc-retrieve-tag)) + (let ((mark-map (make-sparse-keymap))) + (define-key map "*" mark-map) + (define-key mark-map "r" 'vc-dir-mark-registered-files)) + ;; Hook up the menu. (define-key map [menu-bar vc-dir-mode] `(menu-item @@ -696,6 +706,38 @@ share the same state." (vc-dir-mark-file crt))) (setq crt (ewoc-next vc-ewoc crt)))))))) +(defun vc-dir-mark-files (mark-files) + "Mark files specified by file names in the argument MARK-FILES. +MARK-FILES should be a list of absolute filenames." + (ewoc-map + (lambda (filearg) + (when (member (expand-file-name (vc-dir-fileinfo->name filearg)) + mark-files) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + +(defun vc-dir-mark-state-files (states) + "Mark files that are in the state specified by the list in STATES." + (unless (listp states) + (setq states (list states))) + (ewoc-map + (lambda (filearg) + (when (memq (vc-dir-fileinfo->state filearg) states) + (setf (vc-dir-fileinfo->marked filearg) t) + t)) + vc-ewoc)) + +(defun vc-dir-mark-registered-files () + "Mark files that are in one of registered state: edited, added or removed." + (interactive) + (vc-dir-mark-state-files '(edited added removed))) + +(defun vc-dir-mark-unregistered-files () + "Mark files that are in unregistered state." + (interactive) + (vc-dir-mark-state-files 'unregistered)) + (defun vc-dir-unmark-file () ;; Unmark the current file and move to the next line. (let* ((crt (ewoc-locate vc-ewoc)) @@ -1064,6 +1106,7 @@ the *vc-dir* buffer. (set (make-local-variable 'vc-dir-backend) use-vc-backend) (set (make-local-variable 'desktop-save-buffer) 'vc-dir-desktop-buffer-misc-data) + (setq-local bookmark-make-record-function #'vc-dir-bookmark-make-record) (setq buffer-read-only t) (when (boundp 'tool-bar-map) (set (make-local-variable 'tool-bar-map) vc-dir-tool-bar-map)) @@ -1193,7 +1236,8 @@ Throw an error if another update process is in progress." (if remaining (vc-dir-refresh-files (mapcar 'vc-dir-fileinfo->name remaining)) - (setq mode-line-process nil)))))))))))) + (setq mode-line-process nil) + (run-hooks 'vc-dir-refresh-hook)))))))))))) (defun vc-dir-show-fileentry (file) "Insert an entry for a specific file into the current *VC-dir* listing. @@ -1287,6 +1331,16 @@ state of item at point, if any." (list vc-dir-backend files only-files-list state model))) ;;;###autoload +(defun vc-dir-root () + "Run `vc-dir' in the repository root directory without prompt. +If the default directory of the current buffer is +not under version control, prompt for a directory." + (interactive) + (let ((root-dir (vc-root-dir))) + (if root-dir (vc-dir root-dir) + (call-interactively 'vc-dir)))) + +;;;###autoload (defun vc-dir (dir &optional backend) "Show the VC status for \"interesting\" files in and below DIR. This allows you to mark files and perform VC operations on them. @@ -1309,7 +1363,7 @@ These are the commands available for use in the file status buffer: ;; When you hit C-x v d in a visited VC file, ;; the *vc-dir* buffer visits the directory under its truename; ;; therefore it makes sense to always do that. - ;; Otherwise if you do C-x v d -> C-x C-f -> C-c v d + ;; Otherwise if you do C-x v d -> C-x C-f -> C-x v d ;; you may get a new *vc-dir* buffer, different from the original (file-truename (read-directory-name "VC status for directory: " (vc-root-dir) nil t @@ -1413,6 +1467,42 @@ These are the commands available for use in the file status buffer: '(vc-dir-mode . vc-dir-restore-desktop-buffer)) +;;; Support for bookmark.el (adapted from what info.el does). + +(declare-function bookmark-make-record-default + "bookmark" (&optional no-file no-context posn)) +(declare-function bookmark-prop-get "bookmark" (bookmark prop)) +(declare-function bookmark-default-handler "bookmark" (bmk)) +(declare-function bookmark-get-bookmark-record "bookmark" (bmk)) + +(defun vc-dir-bookmark-make-record () + "Make record used to bookmark a `vc-dir' buffer. +This implements the `bookmark-make-record-function' type for +`vc-dir' buffers." + (let* ((bookmark-name + (concat "(" (symbol-name vc-dir-backend) ") " + (file-name-nondirectory + (directory-file-name default-directory)))) + (defaults (list bookmark-name default-directory))) + `(,bookmark-name + ,@(bookmark-make-record-default 'no-file) + (filename . ,default-directory) + (handler . vc-dir-bookmark-jump) + (defaults . ,defaults)))) + +;;;###autoload +(defun vc-dir-bookmark-jump (bmk) + "Provides the bookmark-jump behavior for a `vc-dir' buffer. +This implements the `handler' function interface for the record +type returned by `vc-dir-bookmark-make-record'." + (let* ((file (bookmark-prop-get bmk 'filename)) + (buf (progn ;; Don't use save-window-excursion (bug#39722) + (vc-dir file) + (current-buffer)))) + (bookmark-default-handler + `("" (buffer . ,buf) . ,(bookmark-get-bookmark-record bmk))))) + + (provide 'vc-dir) ;;; vc-dir.el ends here diff --git a/lisp/vc/vc-dispatcher.el b/lisp/vc/vc-dispatcher.el index 5ae300bf09b..4a04c9365a5 100644 --- a/lisp/vc/vc-dispatcher.el +++ b/lisp/vc/vc-dispatcher.el @@ -746,7 +746,8 @@ the buffer contents as a comment." (defun vc-dispatcher-browsing () "Are we in a directory browser buffer?" - (derived-mode-p 'vc-dir-mode)) + (or (derived-mode-p 'vc-dir-mode) + (derived-mode-p 'dired-mode))) ;; These are unused. ;; (defun vc-dispatcher-in-fileset-p (fileset) diff --git a/lisp/vc/vc-git.el b/lisp/vc/vc-git.el index 61e6c642d1f..e0cf9e79595 100644 --- a/lisp/vc/vc-git.el +++ b/lisp/vc/vc-git.el @@ -72,6 +72,7 @@ ;; by git, so it's probably ;; not a good idea. ;; - merge-news (file) see `merge-file' +;; - mark-resolved (file) OK ;; - steal-lock (file &optional revision) NOT NEEDED ;; HISTORY FUNCTIONS ;; * print-log (files buffer &optional shortlog start-revision limit) OK @@ -100,6 +101,7 @@ ;; - rename-file (old new) OK ;; - find-file-hook () OK ;; - conflicted-files OK +;; - repository-url (file-or-dir) OK ;;; Code: @@ -166,7 +168,7 @@ format string (which is passed to \"git log\" via the argument \"--pretty=tformat:FORMAT\"), REGEXP is a regular expression matching the resulting Git log output, and KEYWORDS is a list of `font-lock-keywords' for highlighting the Log View buffer." - :type '(list string string (repeat sexp)) + :type '(list string regexp (repeat sexp)) :version "24.1") (defcustom vc-git-commits-coding-system 'utf-8 @@ -733,6 +735,7 @@ or an empty string if none." (with-current-buffer standard-output (vc-git--out-ok "symbolic-ref" "HEAD")))) (stash-list (vc-git-stash-list)) + (default-directory dir) branch remote remote-url stash-button stash-string) (if (string-match "^\\(refs/heads/\\)?\\(.+\\)$" str) @@ -745,14 +748,8 @@ or an empty string if none." (concat "branch." branch ".remote"))))) (when (string-match "\\([^\n]+\\)" remote) (setq remote (match-string 1 remote))) - (when remote - (setq remote-url - (with-output-to-string - (with-current-buffer standard-output - (vc-git--out-ok "config" - (concat "remote." remote ".url")))))) - (when (string-match "\\([^\n]+\\)" remote-url) - (setq remote-url (match-string 1 remote-url)))) + (when (> (length remote) 0) + (setq remote-url (vc-git-repository-url dir remote)))) (setq branch "not (detached HEAD)")) (when stash-list (let* ((len (length stash-list)) @@ -807,7 +804,7 @@ or an empty string if none." (propertize "Branch : " 'face 'font-lock-type-face) (propertize branch 'face 'font-lock-variable-name-face) - (when remote + (when remote-url (concat "\n" (propertize "Remote : " 'face 'font-lock-type-face) @@ -819,10 +816,10 @@ or an empty string if none." (when (file-exists-p (expand-file-name ".git/rebase-apply" (vc-git-root dir))) (propertize "\nRebase : in progress" 'face 'font-lock-warning-face)) (if stash-list - (concat - (propertize "\nStash : " 'face 'font-lock-type-face) - stash-button - stash-string) + (concat + (propertize "\nStash : " 'face 'font-lock-type-face) + stash-button + stash-string) (concat (propertize "\nStash : " 'face 'font-lock-type-face) (propertize "Nothing stashed" @@ -1081,6 +1078,13 @@ This prompts for a branch to merge from." "DU" "AA" "UU")) (push (expand-file-name file directory) files))))))) +(defun vc-git-repository-url (file-or-dir &optional remote-name) + (let ((default-directory (vc-git-root file-or-dir))) + (with-temp-buffer + (vc-git-command (current-buffer) 0 nil "remote" "get-url" + (or remote-name "origin")) + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + ;; Everywhere but here, follows vc-git-command, which uses vc-do-command ;; from vc-dispatcher. (autoload 'vc-resynch-buffer "vc-dispatcher") @@ -1233,7 +1237,7 @@ log entries." (set (make-local-variable 'log-view-message-re) (if (not (memq vc-log-view-type '(long log-search with-diff))) (cadr vc-git-root-log-format) - "^commit *\\([0-9a-z]+\\)")) + "^commit +\\([0-9a-z]+\\)")) ;; Allow expanding short log entries. (when (memq vc-log-view-type '(short log-outgoing log-incoming mergebase)) (setq truncate-lines t) @@ -1262,7 +1266,7 @@ log entries." ("^Merge: \\([0-9a-z]+\\) \\([0-9a-z]+\\)" (1 'change-log-acknowledgment) (2 'change-log-acknowledgment)) - ("^Date: \\(.+\\)" (1 'change-log-date)) + ("^\\(?:Date: \\|AuthorDate: \\)\\(.+\\)" (1 'change-log-date)) ("^summary:[ \t]+\\(.+\\)" (1 'log-view-message))))))) @@ -1530,6 +1534,9 @@ This requires git 1.8.4 or later, for the \"-L\" option of \"git log\"." (defun vc-git-rename-file (old new) (vc-git-command nil 0 (list old new) "mv" "-f" "--")) +(defun vc-git-mark-resolved (files) + (vc-git-command nil 0 files "add")) + (defvar vc-git-extra-menu-map (let ((map (make-sparse-keymap))) (define-key map [git-grep] diff --git a/lisp/vc/vc-hg.el b/lisp/vc/vc-hg.el index d00b69c0d08..95ced7b8d09 100644 --- a/lisp/vc/vc-hg.el +++ b/lisp/vc/vc-hg.el @@ -182,7 +182,7 @@ is the \"--template\" argument string to pass to Mercurial, REGEXP is a regular expression matching the resulting Mercurial output, and KEYWORDS is a list of `font-lock-keywords' for highlighting the Log View buffer." - :type '(list string string (repeat sexp)) + :type '(list string regexp (repeat sexp)) :group 'vc-hg :version "24.5") @@ -1525,6 +1525,14 @@ This function differs from vc-do-command in that it invokes (defun vc-hg-root (file) (vc-find-root file ".hg")) +(defun vc-hg-repository-url (file-or-dir &optional remote-name) + (let ((default-directory (vc-hg-root file-or-dir))) + (with-temp-buffer + (vc-hg-command (current-buffer) 0 nil + "config" + (concat "paths." (or remote-name "default"))) + (buffer-substring-no-properties (point-min) (1- (point-max)))))) + (provide 'vc-hg) ;;; vc-hg.el ends here diff --git a/lisp/vc/vc-hooks.el b/lisp/vc/vc-hooks.el index 345a28d3f1d..ce72a49b955 100644 --- a/lisp/vc/vc-hooks.el +++ b/lisp/vc/vc-hooks.el @@ -498,7 +498,7 @@ status of this file. Otherwise, the value returned is one of: "Return the repository version from which FILE was checked out. If FILE is not registered, this function always returns nil." (or (vc-file-getprop file 'vc-working-revision) - (progn + (let ((default-directory (file-name-directory file))) (setq backend (or backend (vc-backend file))) (when backend (vc-file-setprop file 'vc-working-revision @@ -972,9 +972,9 @@ In the latter case, VC mode is deactivated for this buffer." (bindings--define-key map [vc-ignore] '(menu-item "Ignore File..." vc-ignore :help "Ignore a file under current version control system")) - (bindings--define-key map [vc-dir] - '(menu-item "VC Dir" vc-dir - :help "Show the VC status of files in a directory")) + (bindings--define-key map [vc-dir-root] + '(menu-item "VC Dir" vc-dir-root + :help "Show the VC status of the repository")) map)) (defalias 'vc-menu-map vc-menu-map) diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 273f37c10d6..23f088b0cff 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -312,7 +312,7 @@ whether to remove it." (and (string= (file-name-nondirectory (directory-file-name dir)) "RCS") ;; check whether RCS dir is empty, i.e. it does not ;; contain any files except "." and ".." - (not (directory-files dir nil (rx (or (not ".") "...")))) + (not (directory-files dir nil directory-files-no-dot-files-regexp)) (yes-or-no-p (format "Directory %s is empty; remove it? " dir)) (delete-directory dir))))) diff --git a/lisp/vc/vc-svn.el b/lisp/vc/vc-svn.el index d039bf3c6a3..e108b3a340f 100644 --- a/lisp/vc/vc-svn.el +++ b/lisp/vc/vc-svn.el @@ -816,7 +816,14 @@ Set file properties accordingly. If FILENAME is non-nil, return its status." (push (match-string 1 loglines) vc-svn-revisions) (setq start (+ start (match-end 0))) (setq loglines (buffer-substring-no-properties start (point-max))))) - vc-svn-revisions))) + vc-svn-revisions))) + +(defun vc-svn-repository-url (file-or-dir &optional _remote-name) + (let ((default-directory (vc-svn-root file-or-dir))) + (with-temp-buffer + (vc-svn-command (current-buffer) 0 nil + "info" "--show-item" "repos-root-url") + (buffer-substring-no-properties (point-min) (1- (point-max)))))) (provide 'vc-svn) diff --git a/lisp/vc/vc.el b/lisp/vc/vc.el index fe666413168..65775f8e46e 100644 --- a/lisp/vc/vc.el +++ b/lisp/vc/vc.el @@ -553,6 +553,13 @@ ;; Return the list of files where conflict resolution is needed in ;; the project that contains DIR. ;; FIXME: what should it do with non-text conflicts? +;; +;; - repository-url (file-or-dir &optional remote-name) +;; +;; Returns the URL of the repository of the current checkout +;; containing FILE-OR-DIR. The optional REMOTE-NAME specifies the +;; remote (in Git parlance) whose URL is to be returned. It has +;; only a meaning for distributed VCS and is ignored otherwise. ;;; Changes from the pre-25.1 API: ;; @@ -957,7 +964,7 @@ use." (throw 'found bk)))) ;;;###autoload -(defun vc-responsible-backend (file) +(defun vc-responsible-backend (file &optional no-error) "Return the name of a backend system that is responsible for FILE. If FILE is already registered, return the @@ -967,7 +974,10 @@ responsible for FILE is returned. Note that if FILE is a symbolic link, it will not be resolved -- the responsible backend system for the symbolic link itself will -be reported." +be reported. + +If NO-ERROR is nil, signal an error that no VC backend is +responsible for the given file." (or (and (not (file-directory-p file)) (vc-backend file)) (catch 'found ;; First try: find a responsible backend. If this is for registration, @@ -975,7 +985,8 @@ be reported." (dolist (backend vc-handled-backends) (and (vc-call-backend backend 'responsible-p file) (throw 'found backend)))) - (error "No VC backend is responsible for %s" file))) + (unless no-error + (error "No VC backend is responsible for %s" file)))) (defun vc-expand-dirs (file-or-dir-list backend) "Expands directories in a file list specification. @@ -1006,35 +1017,47 @@ Within directories, only files already under version control are noticed." (declare-function vc-dir-current-file "vc-dir" ()) (declare-function vc-dir-deduce-fileset "vc-dir" (&optional state-model-only-files)) +(declare-function dired-vc-deduce-fileset "dired-aux" (&optional state-model-only-files not-state-changing)) -(defun vc-deduce-fileset (&optional observer allow-unregistered +(defun vc-deduce-fileset (&optional not-state-changing + allow-unregistered state-model-only-files) "Deduce a set of files and a backend to which to apply an operation. -Return (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL). +Return a list of the form: + + (BACKEND FILESET FILESET-ONLY-FILES STATE CHECKOUT-MODEL) -If we're in VC-dir mode, FILESET is the list of marked files, -or the directory if no files are marked. -Otherwise, if in a buffer visiting a version-controlled file, -FILESET is a single-file fileset containing that file. +where the last 3 members are optional, and must be present only if +STATE-MODEL-ONLY-FILES is non-nil. + +NOT-STATE-CHANGING, if non-nil, means that the operation +requesting the fileset doesn't intend to change the VC state, +such as when printing the log or showing the diffs. + +If the current buffer is in `vc-dir' or Dired mode, FILESET is the +list of marked files, or the current directory if no files are +marked. +Otherwise, if the current buffer is visiting a version-controlled +file, FILESET is a single-file list containing that file's name. Otherwise, if ALLOW-UNREGISTERED is non-nil and the visited file -is unregistered, FILESET is a single-file fileset containing it. +is unregistered, FILESET is a single-file list containing the +name of the visited file. Otherwise, throw an error. -STATE-MODEL-ONLY-FILES if non-nil, means that the caller needs -the FILESET-ONLY-FILES STATE and MODEL info. Otherwise, that -part may be skipped. +STATE-MODEL-ONLY-FILES, if non-nil, means that the caller needs +the FILESET-ONLY-FILES, STATE, and CHECKOUT-MODEL info, where +FILESET-ONLY-FILES means only files in similar VC states, +possible values of STATE are explained in `vc-state', and MODEL in +`vc-checkout-model'. Otherwise, these 3 members may be omitted from +the returned list. BEWARE: this function may change the current buffer." - ;; FIXME: OBSERVER is unused. The name is not intuitive and is not - ;; documented. It's set to t when called from diff and print-log. (let (backend) (cond ((derived-mode-p 'vc-dir-mode) (vc-dir-deduce-fileset state-model-only-files)) ((derived-mode-p 'dired-mode) - (if observer - (vc-dired-deduce-fileset) - (error "State changing VC operations not supported in `dired-mode'"))) + (dired-vc-deduce-fileset state-model-only-files not-state-changing)) ((setq backend (vc-backend buffer-file-name)) (if state-model-only-files (list backend (list buffer-file-name) @@ -1046,15 +1069,14 @@ BEWARE: this function may change the current buffer." ;; FIXME: Why this test? --Stef (or (buffer-file-name vc-parent-buffer) (with-current-buffer vc-parent-buffer - (derived-mode-p 'vc-dir-mode)))) + (or (derived-mode-p 'vc-dir-mode) + (derived-mode-p 'dired-mode))))) (progn ;FIXME: Why not `with-current-buffer'? --Stef. (set-buffer vc-parent-buffer) - (vc-deduce-fileset observer allow-unregistered state-model-only-files))) - ((and (derived-mode-p 'log-view-mode) + (vc-deduce-fileset not-state-changing allow-unregistered state-model-only-files))) + ((and (not buffer-file-name) (setq backend (vc-responsible-backend default-directory))) (list backend nil)) - ((not buffer-file-name) - (error "Buffer %s is not associated with a file" (buffer-name))) ((and allow-unregistered (not (vc-registered buffer-file-name))) (if state-model-only-files (list (vc-backend-for-registration (buffer-file-name)) @@ -1066,10 +1088,6 @@ BEWARE: this function may change the current buffer." (list buffer-file-name)))) (t (error "File is not under version control"))))) -(defun vc-dired-deduce-fileset () - (list (vc-responsible-backend default-directory) - (dired-map-over-marks (dired-get-filename nil t) nil))) - (defun vc-ensure-vc-buffer () "Make sure that the current buffer visits a version-controlled file." (cond @@ -2537,15 +2555,17 @@ with its diffs (if the underlying VCS supports that)." ;;;###autoload (defun vc-print-branch-log (branch) - "Show the change log for BRANCH in a window." + "Show the change log for BRANCH root in a window." (interactive (list (vc-read-revision "Branch to log: "))) (when (equal branch "") (error "No branch specified")) - (vc-print-log-internal (vc-responsible-backend default-directory) - (list default-directory) branch t - (when (> vc-log-show-limit 0) vc-log-show-limit))) + (let* ((backend (vc-responsible-backend default-directory)) + (rootdir (vc-call-backend backend 'root default-directory))) + (vc-print-log-internal backend + (list rootdir) branch t + (when (> vc-log-show-limit 0) vc-log-show-limit)))) ;;;###autoload (defun vc-log-incoming (&optional remote-location) diff --git a/lisp/version.el b/lisp/version.el index bf666cbff99..b247232dcfd 100644 --- a/lisp/version.el +++ b/lisp/version.el @@ -1,4 +1,4 @@ -;;; version.el --- record version number of Emacs +;;; version.el --- record version number of Emacs -*- lexical-binding:t -*- ;; Copyright (C) 1985, 1992, 1994-1995, 1999-2020 Free Software ;; Foundation, Inc. @@ -123,7 +123,7 @@ or if we could not determine the revision.") (looking-at "[[:xdigit:]]\\{40\\}")) (match-string 0))))) -(defun emacs-repository-get-version (&optional dir external) +(defun emacs-repository-get-version (&optional dir _external) "Try to return as a string the repository revision of the Emacs sources. The format of the returned string is dependent on the VCS in use. Value is nil if the sources do not seem to be under version diff --git a/lisp/w32-fns.el b/lisp/w32-fns.el index 8a816da1f2c..c252c0b18f8 100644 --- a/lisp/w32-fns.el +++ b/lisp/w32-fns.el @@ -238,14 +238,18 @@ bit output with no translation." ;; value from x-select-font etc, so list the most important charsets last. (w32-add-charset-info "iso8859-14" 'w32-charset-ansi 28604) (w32-add-charset-info "iso8859-15" 'w32-charset-ansi 28605) + (w32-add-charset-info "iso8859-16" 'w32-charset-ansi 28606) ;; The following two are included for pattern matching. (w32-add-charset-info "jisx0201" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0208" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-latin" 'w32-charset-shiftjis 932) (w32-add-charset-info "jisx0201-katakana" 'w32-charset-shiftjis 932) + (w32-add-charset-info "jisx0212" 'w32-charset-shiftjis 932) (w32-add-charset-info "ksc5601.1989" 'w32-charset-hangeul 949) + (w32-add-charset-info "ksx1001" 'w32-charset-hangeul 949) (w32-add-charset-info "big5" 'w32-charset-chinesebig5 950) (w32-add-charset-info "gb2312.1980" 'w32-charset-gb2312 936) + (w32-add-charset-info "gbk" 'w32-charset-gb2312 936) (w32-add-charset-info "ms-symbol" 'w32-charset-symbol nil) (w32-add-charset-info "ms-oem" 'w32-charset-oem 437) (w32-add-charset-info "ms-oemlatin" 'w32-charset-oem 850) @@ -258,9 +262,12 @@ bit output with no translation." (w32-add-charset-info "iso8859-9" 'w32-charset-turkish 1254) (w32-add-charset-info "iso8859-13" 'w32-charset-baltic 1257) (w32-add-charset-info "koi8-r" 'w32-charset-russian 20866) + (w32-add-charset-info "microsoft-cp1251" 'w32-charset-russian 1251) + (w32-add-charset-info "windows-1251" 'w32-charset-russian 1251) (w32-add-charset-info "tis620-2533" 'w32-charset-russian 28595) (w32-add-charset-info "iso8859-11" 'w32-charset-thai 874) (w32-add-charset-info "windows-1258" 'w32-charset-vietnamese 1258) + (w32-add-charset-info "viscii" 'w32-charset-vietnamese 1258) (w32-add-charset-info "ksc5601.1992" 'w32-charset-johab 1361) (w32-add-charset-info "mac-roman" 'w32-charset-mac 10000) (w32-add-charset-info "iso10646-1" 'w32-charset-default t) diff --git a/lisp/w32-vars.el b/lisp/w32-vars.el index 307490dc4b0..642a48446ef 100644 --- a/lisp/w32-vars.el +++ b/lisp/w32-vars.el @@ -1,4 +1,4 @@ -;;; w32-vars.el --- MS-Windows specific user options +;;; w32-vars.el --- MS-Windows specific user options -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -44,22 +44,19 @@ after changing the value of this variable." :type 'boolean :set (lambda (symbol value) (set symbol value) - (setq mouse-appearance-menu-map nil)) - :group 'w32) + (setq mouse-appearance-menu-map nil))) (unless (eq system-type 'cygwin) (defcustom w32-allow-system-shell nil "Disable startup warning when using \"system\" shells." - :type 'boolean - :group 'w32)) + :type 'boolean)) (unless (eq system-type 'cygwin) (defcustom w32-system-shells '("cmd" "cmd.exe" "command" "command.com" "4nt" "4nt.exe" "4dos" "4dos.exe" "tcc" "tcc.exe" "ndos" "ndos.exe") "List of strings recognized as Windows system shells." - :type '(repeat string) - :group 'w32)) + :type '(repeat string))) ;; Want "menu" custom type for this. (defcustom w32-fixed-font-alist @@ -149,8 +146,7 @@ menu if the variable `w32-use-w32-font-dialog' is nil." (const :tag "Separator" ("")) (list :tag "Font Entry" (string :tag "Menu text") - (string :tag "Font"))))))) - :group 'w32) + (string :tag "Font")))))))) (make-obsolete-variable 'w32-enable-synthesized-fonts nil "24.4") diff --git a/lisp/wdired.el b/lisp/wdired.el index d91853e64dd..768b8f597b4 100644 --- a/lisp/wdired.el +++ b/lisp/wdired.el @@ -4,7 +4,7 @@ ;; Filename: wdired.el ;; Author: Juan León Lahoz García <juanleon1@gmail.com> -;; Version: 2.0 +;; Old-Version: 2.0 ;; Keywords: dired, environment, files, renaming ;; This file is part of GNU Emacs. @@ -640,6 +640,7 @@ Optional arguments are ignored." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "^p") + (setq this-command 'next-line) ;Let `line-move' preserve the column. (with-no-warnings (next-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement @@ -653,6 +654,7 @@ says how many lines to move; default is one line." See `wdired-use-dired-vertical-movement'. Optional prefix ARG says how many lines to move; default is one line." (interactive "^p") + (setq this-command 'previous-line) ;Let `line-move' preserve the column. (with-no-warnings (previous-line arg)) (if (or (eq wdired-use-dired-vertical-movement t) (and wdired-use-dired-vertical-movement diff --git a/lisp/whitespace.el b/lisp/whitespace.el index db7c023324b..47434bf3d2e 100644 --- a/lisp/whitespace.el +++ b/lisp/whitespace.el @@ -716,8 +716,8 @@ and the cons cdr is used for TABs visualization. Used when `whitespace-style' includes `indentation', `indentation::tab' or `indentation::space'." - :type '(cons (string :tag "Indentation SPACEs") - (string :tag "Indentation TABs")) + :type '(cons (regexp :tag "Indentation SPACEs") + (regexp :tag "Indentation TABs")) :group 'whitespace) @@ -747,8 +747,8 @@ and the cons cdr is used for TABs visualization. Used when `whitespace-style' includes `space-after-tab', `space-after-tab::tab' or `space-after-tab::space'." - :type '(cons (string :tag "SPACEs After TAB") - string) + :type '(cons (regexp :tag "SPACEs After TAB") + regexp) :group 'whitespace) (defcustom whitespace-big-indent-regexp @@ -2067,16 +2067,7 @@ resultant list will be returned." ,@(when (or (memq 'lines whitespace-active-style) (memq 'lines-tail whitespace-active-style)) ;; Show "long" lines. - `((,(let ((line-column (or whitespace-line-column fill-column))) - (format - "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$" - tab-width - (1- tab-width) - (/ line-column tab-width) - (let ((rem (% line-column tab-width))) - (if (zerop rem) - "" - (format ".\\{%d\\}" rem))))) + `((,#'whitespace-lines-regexp ,(if (memq 'lines whitespace-active-style) 0 ; whole line 2) ; line tail @@ -2177,6 +2168,19 @@ resultant list will be returned." (setq status nil))) ;; end of buffer status)) +(defun whitespace-lines-regexp (limit) + (re-search-forward + (let ((line-column (or whitespace-line-column fill-column))) + (format + "^\\([^\t\n]\\{%s\\}\\|[^\t\n]\\{0,%s\\}\t\\)\\{%d\\}%s\\(.+\\)$" + tab-width + (1- tab-width) + (/ line-column tab-width) + (let ((rem (% line-column tab-width))) + (if (zerop rem) + "" + (format ".\\{%d\\}" rem))))) + limit t)) (defun whitespace-empty-at-bob-regexp (limit) "Match spaces at beginning of buffer which do not contain the point at \ diff --git a/lisp/wid-edit.el b/lisp/wid-edit.el index 62846523be4..284fd1d6cbd 100644 --- a/lisp/wid-edit.el +++ b/lisp/wid-edit.el @@ -236,8 +236,7 @@ minibuffer." ;; Construct a menu of the choices ;; and then use it for prompting for a single character. (let* ((next-digit ?0) - (map (make-sparse-keymap)) - choice some-choice-enabled value) + alist choice some-choice-enabled value) (with-current-buffer (get-buffer-create " widget-choose") (erase-buffer) (insert "Available choices:\n\n") @@ -247,7 +246,7 @@ minibuffer." (let* ((name (substitute-command-keys (car choice))) (function (cdr choice))) (insert (format "%c = %s\n" next-digit name)) - (define-key map (vector next-digit) function) + (push (cons next-digit function) alist) (setq some-choice-enabled t))) ;; Allocate digits to disabled alternatives ;; so that the digit of a given alternative never varies. @@ -257,33 +256,17 @@ minibuffer." (forward-line)) (or some-choice-enabled (error "None of the choices is currently meaningful")) - (define-key map [?\M-\C-v] 'scroll-other-window) - (define-key map [?\M--] 'negative-argument) (save-window-excursion - (let ((buf (get-buffer " widget-choose"))) - (display-buffer buf - '(display-buffer-in-direction - (direction . bottom) - (window-height . fit-window-to-buffer))) - (let ((cursor-in-echo-area t) - (arg 1)) - (while (not value) - (setq value (lookup-key map (read-key-sequence (format "%s: " title)))) - (unless value - (user-error "Canceled")) - (when - (cond ((eq value 'scroll-other-window) - (let ((minibuffer-scroll-window - (get-buffer-window buf))) - (if (> 0 arg) - (scroll-other-window-down - (window-height minibuffer-scroll-window)) - (scroll-other-window)) - (setq arg 1))) - ((eq value 'negative-argument) - (setq arg -1))) - (setq value nil)))))) - value)))) + ;; Select window to be able to scroll it from minibuffer + (with-selected-window + (display-buffer (get-buffer " widget-choose") + '(display-buffer-in-direction + (direction . bottom) + (window-height . fit-window-to-buffer))) + (setq value (read-char-from-minibuffer + (format "%s: " title) + (mapcar #'car alist))))) + (cdr (assoc value alist)))))) ;;; Widget text specifications. ;; diff --git a/lisp/windmove.el b/lisp/windmove.el index 6e62e161548..65579600640 100644 --- a/lisp/windmove.el +++ b/lisp/windmove.el @@ -461,50 +461,38 @@ select the window with a displayed buffer, and the meaning of the prefix argument is reversed. When `switch-to-buffer-obey-display-actions' is non-nil, `switch-to-buffer' commands are also supported." - (let* ((no-select (xor (consp arg) windmove-display-no-select)) - (old-window (or (minibuffer-selected-window) (selected-window))) - (new-window) - (minibuffer-depth (minibuffer-depth)) - (action (lambda (buffer alist) - (unless (> (minibuffer-depth) minibuffer-depth) - (let ((window (cond - ((eq dir 'new-tab) - (let ((tab-bar-new-tab-choice t)) - (tab-bar-new-tab)) - (selected-window)) - ((eq dir 'same-window) - (selected-window)) - (t (window-in-direction - dir nil nil - (and arg (prefix-numeric-value arg)) - windmove-wrap-around)))) - (type 'reuse)) - (unless window - (setq window (split-window nil nil dir) type 'window)) - (setq new-window (window--display-buffer buffer window - type alist)))))) - (command this-command) - (clearfun (make-symbol "clear-display-buffer-overriding-action")) - (exitfun - (lambda () - (setq display-buffer-overriding-action - (delq action display-buffer-overriding-action)) - (when (window-live-p (if no-select old-window new-window)) - (select-window (if no-select old-window new-window))) - (remove-hook 'post-command-hook clearfun)))) - (fset clearfun - (lambda () - (unless (or - ;; Remove the hook immediately - ;; after exiting the minibuffer. - (> (minibuffer-depth) minibuffer-depth) - ;; But don't remove immediately after - ;; adding the hook by the same command below. - (eq this-command command)) - (funcall exitfun)))) - (add-hook 'post-command-hook clearfun) - (push action display-buffer-overriding-action) - (message "[display-%s]" dir))) + (let ((no-select (xor (consp arg) windmove-display-no-select))) + (display-buffer-override-next-command + (lambda (_buffer alist) + (let* ((type 'reuse) + (window (cond + ((eq dir 'new-tab) + (let ((tab-bar-new-tab-choice t)) + (tab-bar-new-tab)) + (setq type 'tab) + (selected-window)) + ((eq dir 'new-frame) + (let* ((params (cdr (assq 'pop-up-frame-parameters alist))) + (pop-up-frame-alist (append params pop-up-frame-alist)) + (frame (make-frame-on-current-monitor + pop-up-frame-alist))) + (unless (cdr (assq 'inhibit-switch-frame alist)) + (window--maybe-raise-frame frame)) + (setq type 'frame) + (frame-selected-window frame))) + ((eq dir 'same-window) + (selected-window)) + (t (window-in-direction + dir nil nil + (and arg (prefix-numeric-value arg)) + windmove-wrap-around))))) + (unless window + (setq window (split-window nil nil dir) type 'window)) + (cons window type))) + (lambda (old-window new-window) + (when (window-live-p (if no-select old-window new-window)) + (select-window (if no-select old-window new-window)))) + (format "[display-%s]" dir)))) ;;;###autoload (defun windmove-display-left (&optional arg) @@ -541,6 +529,12 @@ See the logic of the prefix ARG in `windmove-display-in-direction'." (windmove-display-in-direction 'same-window arg)) ;;;###autoload +(defun windmove-display-new-frame (&optional arg) + "Display the next buffer in a new frame." + (interactive "P") + (windmove-display-in-direction 'new-frame arg)) + +;;;###autoload (defun windmove-display-new-tab (&optional arg) "Display the next buffer in a new tab." (interactive "P") @@ -561,6 +555,7 @@ Default value of MODIFIERS is `shift-meta'." (global-set-key (vector (append modifiers '(up))) 'windmove-display-up) (global-set-key (vector (append modifiers '(down))) 'windmove-display-down) (global-set-key (vector (append modifiers '(?0))) 'windmove-display-same-window) + (global-set-key (vector (append modifiers '(?f))) 'windmove-display-new-frame) (global-set-key (vector (append modifiers '(?t))) 'windmove-display-new-tab)) diff --git a/lisp/window.el b/lisp/window.el index 5c4ff83d82d..f20940fa0ea 100644 --- a/lisp/window.el +++ b/lisp/window.el @@ -226,7 +226,9 @@ BODY." "Show a buffer BUFFER-OR-NAME and evaluate BODY in that buffer. This construct is like `with-current-buffer-window' but unlike that, displays the buffer specified by BUFFER-OR-NAME before running BODY." - (declare (debug t) (indent 3)) + (declare (debug t) (indent 3) + (obsolete "use `with-current-buffer-window' with action alist entry `body-function'." + "28.1")) (let ((buffer (make-symbol "buffer")) (window (make-symbol "window")) (value (make-symbol "value"))) @@ -278,6 +280,24 @@ displays the buffer specified by BUFFER-OR-NAME before running BODY." (funcall ,vquit-function ,window ,value) ,value))))) +(defmacro with-window-non-dedicated (window &rest body) + "Evaluate BODY with WINDOW temporarily made non-dedicated. +If WINDOW is nil, use the selected window. Return the value of +the last form in BODY." + (declare (indent 1) (debug t)) + (let ((window-dedicated-sym (gensym)) + (window-sym (gensym))) + `(let* ((,window-sym (window-normalize-window ,window t)) + (,window-dedicated-sym (window-dedicated-p ,window-sym))) + (set-window-dedicated-p ,window-sym nil) + (unwind-protect + (progn ,@body) + ;; `window-dedicated-p' returns the value set by + ;; `set-window-dedicated-p', which differentiates non-nil and + ;; t, so we cannot simply use t here. That's why we use + ;; `window-dedicated-sym'. + (set-window-dedicated-p ,window-sym ,window-dedicated-sym))))) + ;; The following two functions are like `window-next-sibling' and ;; `window-prev-sibling' but the WINDOW argument is _not_ optional (so ;; they don't substitute the selected window for nil), and they return @@ -3911,7 +3931,7 @@ TOP RIGHT BOTTOM) as returned by `window-edges'." (setq frame (window-normalize-frame frame)) (window--subtree (frame-root-window frame) t)) -(defun other-window (count &optional all-frames) +(defun other-window (count &optional all-frames interactive) "Select another window in cyclic ordering of windows. COUNT specifies the number of windows to skip, starting with the selected window, before making the selection. If COUNT is @@ -3931,7 +3951,7 @@ This function uses `next-window' for finding the window to select. The argument ALL-FRAMES has the same meaning as in `next-window', but the MINIBUF argument of `next-window' is always effectively nil." - (interactive "p") + (interactive "p\ni\np") (let* ((window (selected-window)) (original-window window) (function (and (not ignore-window-parameters) @@ -3977,13 +3997,53 @@ always effectively nil." (setq count (1+ count))))) (when (and (eq window original-window) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (message "No other window to select")) (select-window window) ;; Always return nil. nil)))) +(defun other-window-prefix () + "Display the buffer of the next command in a new window. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Creates a new window before displaying the buffer. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (let ((alist (append '((inhibit-same-window . t)) alist)) + window type) + (if (setq window (display-buffer-pop-up-window buffer alist)) + (setq type 'window) + (setq window (display-buffer-use-some-window buffer alist) + type 'reuse)) + (cons window type))) + nil "[other-window]") + (message "Display next command buffer in a new window...")) + +(defun same-window-prefix () + "Display the buffer of the next command in the same window. +The next buffer is the buffer displayed by the next command invoked +immediately after this command (ignoring reading from the minibuffer). +Even when the default rule should display the buffer in a new window, +force its display in the already selected window. +When `switch-to-buffer-obey-display-actions' is non-nil, +`switch-to-buffer' commands are also supported." + (interactive) + (display-buffer-override-next-command + (lambda (buffer alist) + (setq alist (append '((inhibit-same-window . nil)) alist)) + (cons (or + (display-buffer-same-window buffer alist) + (display-buffer-use-some-window buffer alist)) + 'reuse)) + nil "[same-window]") + (message "Display next command buffer in the same window...")) + ;; This should probably return non-nil when the selected window is part ;; of an atomic window whose root is the frame's root window. (defun one-window-p (&optional nomini all-frames) @@ -4192,7 +4252,7 @@ that is its frame's root window." ;; Always return nil. nil)))) -(defun delete-other-windows (&optional window) +(defun delete-other-windows (&optional window interactive) "Make WINDOW fill its frame. WINDOW must be a valid window and defaults to the selected one. Return nil. @@ -4209,7 +4269,7 @@ with the root of the atomic window as its argument. Signal an error if that root window is the root window of WINDOW's frame. Also signal an error if WINDOW is a side window. Do not delete any window whose `no-delete-other-windows' parameter is non-nil." - (interactive) + (interactive "i\np") (setq window (window-normalize-window window)) (let* ((frame (window-frame window)) (function (window-parameter window 'delete-other-windows)) @@ -4275,7 +4335,8 @@ any window whose `no-delete-other-windows' parameter is non-nil." (if (eq window main) ;; Give a message to the user if this has been called as a ;; command. - (when (called-interactively-p 'interactive) + (when (and interactive + (not (or executing-kbd-macro noninteractive))) (message "No other windows to delete")) (delete-other-windows-internal window main) (window--check frame)) @@ -4838,11 +4899,11 @@ displayed there." (interactive) (switch-to-buffer (last-buffer))) -(defun next-buffer (&optional arg) +(defun next-buffer (&optional arg interactive) "In selected window switch to ARGth next buffer. Call `switch-to-next-buffer' unless the selected window is the minibuffer window or is dedicated to its buffer." - (interactive "p") + (interactive "p\np") (cond ((window-minibuffer-p) (user-error "Cannot switch buffers in minibuffer window")) @@ -4851,14 +4912,15 @@ minibuffer window or is dedicated to its buffer." (t (dotimes (_ (or arg 1)) (when (and (not (switch-to-next-buffer)) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (user-error "No next buffer")))))) -(defun previous-buffer (&optional arg) +(defun previous-buffer (&optional arg interactive) "In selected window switch to ARGth previous buffer. Call `switch-to-prev-buffer' unless the selected window is the minibuffer window or is dedicated to its buffer." - (interactive "p") + (interactive "p\np") (cond ((window-minibuffer-p) (user-error "Cannot switch buffers in minibuffer window")) @@ -4867,7 +4929,8 @@ minibuffer window or is dedicated to its buffer." (t (dotimes (_ (or arg 1)) (when (and (not (switch-to-prev-buffer)) - (called-interactively-p 'interactive)) + interactive + (not (or executing-kbd-macro noninteractive))) (user-error "No previous buffer")))))) (defun delete-windows-on (&optional buffer-or-name frame) @@ -5009,6 +5072,13 @@ nil means to not handle the buffer in a particular way. This quad entry) (cond ((and (not prev-buffer) + (eq (nth 1 quit-restore) 'tab) + (eq (nth 3 quit-restore) buffer)) + (tab-bar-close-tab) + ;; If the previously selected window is still alive, select it. + (when (window-live-p (nth 2 quit-restore)) + (select-window (nth 2 quit-restore)))) + ((and (not prev-buffer) (or (eq (nth 1 quit-restore) 'frame) (and (eq (nth 1 quit-restore) 'window) ;; If the window has been created on an existing @@ -6367,7 +6437,12 @@ fourth element is BUFFER." ;; WINDOW has been created on a new frame. (set-window-parameter window 'quit-restore - (list 'frame 'frame (selected-window) buffer))))) + (list 'frame 'frame (selected-window) buffer))) + ((eq type 'tab) + ;; WINDOW has been created on a new tab. + (set-window-parameter + window 'quit-restore + (list 'tab 'tab (selected-window) buffer))))) (defcustom display-buffer-function nil "If non-nil, function to call to handle `display-buffer'. @@ -7034,8 +7109,14 @@ Return WINDOW if BUFFER and WINDOW are live." ;; use that. (display-buffer-mark-dedicated (set-window-dedicated-p window display-buffer-mark-dedicated)))) - (when (memq type '(window frame)) + (when (memq type '(window frame tab)) (set-window-prev-buffers window nil)) + + (when (functionp (cdr (assq 'body-function alist))) + (let ((inhibit-read-only t) + (inhibit-modification-hooks t)) + (funcall (cdr (assq 'body-function alist)) window))) + (let ((quit-restore (window-parameter window 'quit-restore)) (height (cdr (assq 'window-height alist))) (width (cdr (assq 'window-width alist))) @@ -7363,6 +7444,12 @@ Action alist entries are: parameters to give the chosen window. `allow-no-window' -- A non-nil value means that `display-buffer' may not display the buffer and return nil immediately. + `body-function' -- A function called with one argument - the + displayed window. It is called after the buffer is + displayed, and before `window-height', `window-width' + and `preserve-size' are applied. The function is supposed + to fill the window body with some contents that might depend + on dimensions of the displayed window. The entries `window-height', `window-width' and `preserve-size' are applied only when the window used for displaying the buffer @@ -7879,15 +7966,15 @@ Info node `(elisp) Buffer Display Action Alists' for details of such alists. ALIST has to contain a `direction' entry whose value should be -one of `left', `above' (or `up'), `right' and `below' (or -'down'). Other values are usually interpreted as `below'. +one of `left', `above' (or `up'), `right' and `below' (or `down'). +Other values are usually interpreted as `below'. If ALIST also contains a `window' entry, its value specifies a reference window. That value can be a special symbol like -'main' (which stands for the selected frame's main window) or -'root' (standings for the selected frame's root window) or an +`main' (which stands for the selected frame's main window) or +`root' (standings for the selected frame's root window) or an arbitrary valid window. Any other value (or omitting the -'window' entry) means to use the selected window as reference +`window' entry) means to use the selected window as reference window. This function tries to reuse or split a window such that the @@ -8530,6 +8617,60 @@ documentation for additional customization information." (interactive (list (read-buffer-to-switch "Switch to buffer in other frame: "))) (pop-to-buffer buffer-or-name display-buffer--other-frame-action norecord)) + +(defun display-buffer-override-next-command (pre-function &optional post-function echo) + "Set `display-buffer-overriding-action' for the next command. +`pre-function' is called to prepare the window where the buffer should be +displayed. This function takes two arguments `buffer' and `alist', and +should return a cons with the displayed window and its type. See the +meaning of these values in `window--display-buffer'. +Optional `post-function' is called after the buffer is displayed in the +window; the function takes two arguments: an old and new window. +Optional string argument `echo' can be used to add a prefix to the +command echo keystrokes that should describe the current prefix state." + (let* ((old-window (or (minibuffer-selected-window) (selected-window))) + (new-window nil) + (minibuffer-depth (minibuffer-depth)) + (clearfun (make-symbol "clear-display-buffer-overriding-action")) + (action (lambda (buffer alist) + (unless (> (minibuffer-depth) minibuffer-depth) + (let* ((ret (funcall pre-function buffer alist)) + (window (car ret)) + (type (cdr ret))) + (setq new-window (window--display-buffer buffer window + type alist)) + ;; Reset display-buffer-overriding-action + ;; after the first buffer display action + (funcall clearfun) + (setq post-function nil) + new-window)))) + (command this-command) + (echofun (when echo (lambda () echo))) + (exitfun + (lambda () + (setcar display-buffer-overriding-action + (delq action (car display-buffer-overriding-action))) + (remove-hook 'post-command-hook clearfun) + (remove-hook 'prefix-command-echo-keystrokes-functions echofun) + (when (functionp post-function) + (funcall post-function old-window new-window))))) + (fset clearfun + (lambda () + (unless (or + ;; Remove the hook immediately + ;; after exiting the minibuffer. + (> (minibuffer-depth) minibuffer-depth) + ;; But don't remove immediately after + ;; adding the hook by the same command below. + (eq this-command command)) + (funcall exitfun)))) + ;; Reset display-buffer-overriding-action + ;; after the next command finishes + (add-hook 'post-command-hook clearfun) + (when echofun + (add-hook 'prefix-command-echo-keystrokes-functions echofun)) + (push action (car display-buffer-overriding-action)))) + (defun set-window-text-height (window height) "Set the height in lines of the text display area of WINDOW to HEIGHT. @@ -8590,16 +8731,32 @@ in some window." (setq end (point-max))) (if (= beg end) 0 - (save-excursion - (save-restriction - (widen) - (narrow-to-region (min beg end) - (if (and (not count-final-newline) - (= ?\n (char-before (max beg end)))) - (1- (max beg end)) - (max beg end))) - (goto-char (point-min)) - (1+ (vertical-motion (buffer-size) window)))))) + (let ((start (min beg end)) + (finish (max beg end)) + count end-invisible-p) + ;; When END is invisible because lines are truncated in WINDOW, + ;; vertical-motion returns a number that is 1 larger than it + ;; should. We need to fix that. + (setq end-invisible-p + (and (or truncate-lines + (and (natnump truncate-partial-width-windows) + (< (window-total-width window) + truncate-partial-width-windows))) + (save-excursion + (goto-char finish) + (> (- (current-column) (window-hscroll window)) + (window-body-width window))))) + (save-excursion + (save-restriction + (widen) + (narrow-to-region start + (if (and (not count-final-newline) + (= ?\n (char-before finish))) + (1- finish) + finish)) + (goto-char start) + (setq count (vertical-motion (buffer-size) window)) + (if end-invisible-p count (1+ count))))))) (defun window-buffer-height (window) "Return the height (in screen lines) of the buffer that WINDOW is displaying. @@ -10019,5 +10176,7 @@ displaying that processes's buffer." (define-key ctl-x-map "-" 'shrink-window-if-larger-than-buffer) (define-key ctl-x-map "+" 'balance-windows) (define-key ctl-x-4-map "0" 'kill-buffer-and-window) +(define-key ctl-x-4-map "1" 'same-window-prefix) +(define-key ctl-x-4-map "4" 'other-window-prefix) ;;; window.el ends here diff --git a/lisp/woman.el b/lisp/woman.el index 8465ab7c32e..c0e27c57077 100644 --- a/lisp/woman.el +++ b/lisp/woman.el @@ -6,7 +6,7 @@ ;; Maintainer: emacs-devel@gnu.org ;; Keywords: help, unix ;; Adapted-By: Eli Zaretskii <eliz@gnu.org> -;; Version: 0.551 +;; Old-Version: 0.551 ;; URL: http://centaur.maths.qmul.ac.uk/Emacs/WoMan/ ;; This file is part of GNU Emacs. @@ -401,6 +401,7 @@ ;;; Code: (defvar woman-version "0.551 (beta)" "WoMan version information.") +(make-obsolete-variable 'woman-version nil "28.1") (require 'man) (require 'button) @@ -674,7 +675,7 @@ These normally have names of the form `man?'. Its default value is \"[Mm][Aa][Nn]\", which is case-insensitive mainly for the benefit of Microsoft platforms. Its purpose is to avoid `cat?', `.', `..', etc." ;; Based on a suggestion by Wei-Xue Shi. - :type 'string + :type 'regexp :group 'woman-interface) (defcustom woman-path @@ -753,7 +754,7 @@ Default is t." An alist with elements of the form (MENU-TITLE REGEXP INDEX) -- see the documentation for `imenu-generic-expression'." :type '(alist :key-type (choice :tag "Title" (const nil) string) - :value-type (group (choice (string :tag "Regexp") + :value-type (group (choice (regexp :tag "Regexp") function) integer)) :group 'woman-interface) @@ -1830,7 +1831,6 @@ Argument EVENT is the invoking mouse event." ["Mini Help" woman-mini-help t] ,@(if (fboundp 'customize-group) '(["Customize..." (customize-group 'woman) t])) - ["Show Version" (message "WoMan %s" woman-version) t] "--" ("Advanced" ["View Source" (view-file woman-last-file-name) woman-last-file-name] @@ -1878,7 +1878,6 @@ Argument EVENT is the invoking mouse event." WoMan is an ELisp emulation of much of the functionality of the Emacs `man' command running the standard UN*X man and ?roff programs. WoMan author: F.J.Wright@Maths.QMW.ac.uk -WoMan version: see `woman-version'. See `Man-mode' for additional details. \\{woman-mode-map}" (let ((Man-build-page-list (symbol-function 'Man-build-page-list)) diff --git a/lisp/x-dnd.el b/lisp/x-dnd.el index ea9d119e2ff..b22af5cc770 100644 --- a/lisp/x-dnd.el +++ b/lisp/x-dnd.el @@ -412,19 +412,13 @@ FRAME is the frame and W is the window where the drop happened. If W is a window, return its absolute coordinates, otherwise return the frame coordinates." (let* ((frame-left (frame-parameter frame 'left)) - ;; If the frame is outside the display, frame-left looks like - ;; '(0 -16). Extract the -16. - (frame-real-left (if (consp frame-left) (car (cdr frame-left)) - frame-left)) - (frame-top (frame-parameter frame 'top)) - (frame-real-top (if (consp frame-top) (car (cdr frame-top)) - frame-top))) + (frame-top (frame-parameter frame 'top))) (if (windowp w) (let ((edges (window-inside-pixel-edges w))) (cons - (+ frame-real-left (nth 0 edges)) - (+ frame-real-top (nth 1 edges)))) - (cons frame-real-left frame-real-top)))) + (+ frame-left (nth 0 edges)) + (+ frame-top (nth 1 edges)))) + (cons frame-left frame-top)))) (declare-function x-get-atom-name "xselect.c" (value &optional frame)) (declare-function x-send-client-message "xselect.c" @@ -434,15 +428,11 @@ otherwise return the frame coordinates." (defun x-dnd-version-from-flags (flags) "Return the version byte from the 32 bit FLAGS in an XDndEnter message." - (if (consp flags) ;; Long as cons - (ash (car flags) -8) - (ash flags -24))) ;; Ordinary number + (ash flags -24)) (defun x-dnd-more-than-3-from-flags (flags) "Return the nmore-than3 bit from the 32 bit FLAGS in an XDndEnter message." - (if (consp flags) - (logand (cdr flags) 1) - (logand flags 1))) + (logand flags 1)) (defun x-dnd-handle-xdnd (event frame window message _format data) "Receive one XDND event (client message) and send the appropriate reply. @@ -454,7 +444,7 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (version (x-dnd-version-from-flags flags)) (more-than-3 (x-dnd-more-than-3-from-flags flags)) (dnd-source (aref data 0))) - (message "%s %s" version more-than-3) + (message "%s %s" version more-than-3) (if version ;; If flags is bad, version will be nil. (x-dnd-save-state window nil nil @@ -495,10 +485,12 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ((equal "XdndDrop" message) (if (windowp window) (select-window window)) (let* ((dnd-source (aref data 0)) + (timestamp (aref data 2)) (value (and (x-dnd-current-type window) (x-get-selection-internal 'XdndSelection - (intern (x-dnd-current-type window))))) + (intern (x-dnd-current-type window)) + timestamp))) success action) (setq action (if value @@ -545,14 +537,14 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." ((eq size 4) (if (eq byteorder ?l) - (cons (+ (ash (aref data (+ 3 offset)) 8) - (aref data (+ 2 offset))) - (+ (ash (aref data (1+ offset)) 8) - (aref data offset))) - (cons (+ (ash (aref data offset) 8) - (aref data (1+ offset))) - (+ (ash (aref data (+ 2 offset)) 8) - (aref data (+ 3 offset)))))))) + (+ (ash (aref data (+ 3 offset)) 24) + (ash (aref data (+ 2 offset)) 16) + (ash (aref data (1+ offset)) 8) + (aref data offset)) + (+ (ash (aref data offset) 24) + (ash (aref data (1+ offset)) 16) + (ash (aref data (+ 2 offset)) 8) + (aref data (+ 3 offset))))))) (defun x-dnd-motif-value-to-list (value size byteorder) (let ((bytes (cond ((eq size 2) @@ -560,15 +552,10 @@ FORMAT is 32 (not used). MESSAGE is the data part of an XClientMessageEvent." (logand value ?\xff))) ((eq size 4) - (if (consp value) - (list (logand (ash (car value) -8) ?\xff) - (logand (car value) ?\xff) - (logand (ash (cdr value) -8) ?\xff) - (logand (cdr value) ?\xff)) - (list (logand (ash value -24) ?\xff) - (logand (ash value -16) ?\xff) - (logand (ash value -8) ?\xff) - (logand value ?\xff))))))) + (list (logand (ash value -24) ?\xff) + (logand (ash value -16) ?\xff) + (logand (ash value -8) ?\xff) + (logand value ?\xff)))))) (if (eq byteorder ?l) (reverse bytes) bytes))) diff --git a/lisp/xml.el b/lisp/xml.el index dc774a202cf..10ef8e2087a 100644 --- a/lisp/xml.el +++ b/lisp/xml.el @@ -1023,9 +1023,18 @@ entity references (e.g., replace each & with &). XML character data must not contain & or < characters, nor the > character under some circumstances. The XML spec does not impose restriction on \" or \\=', but we just substitute for these too -\(as is permitted by the spec)." +\(as is permitted by the spec). + +If STRING contains characters that are invalid in XML (as defined +by https://www.w3.org/TR/xml/#charsets), signal an error of type +`xml-invalid-character'." (with-temp-buffer (insert string) + (goto-char (point-min)) + (when (re-search-forward + "[^\u0009\u000A\u000D\u0020-\uD7FF\uE000-\uFFFD\U00010000-\U0010FFFF]" + nil t) + (signal 'xml-invalid-character (list (char-before) (match-beginning 0)))) (dolist (substitution '(("&" . "&") ("<" . "<") (">" . ">") @@ -1036,6 +1045,9 @@ restriction on \" or \\=', but we just substitute for these too (replace-match (cdr substitution) t t nil))) (buffer-string))) +(define-error 'xml-invalid-character "Invalid XML character" + 'wrong-type-argument) + (defun xml-debug-print-internal (xml indent-string) "Outputs the XML tree in the current buffer. The first line is indented with INDENT-STRING." diff --git a/lisp/xwidget.el b/lisp/xwidget.el index 775dddf8ef6..aed6c09122c 100644 --- a/lisp/xwidget.el +++ b/lisp/xwidget.el @@ -92,6 +92,9 @@ Interactively, URL defaults to the string looking like a url around point." (or (featurep 'xwidget-internal) (user-error "Your Emacs was not compiled with xwidgets support")) (when (stringp url) + ;; If it's a "naked url", just try adding https: to it. + (unless (string-match "\\`[A-Za-z]+:" url) + (setq url (concat "https://" url))) (if new-session (xwidget-webkit-new-session url) (xwidget-webkit-goto-url url)))) diff --git a/m4/00gnulib.m4 b/m4/00gnulib.m4 index 1a1a1d74f7e..06eff4f3863 100644 --- a/m4/00gnulib.m4 +++ b/m4/00gnulib.m4 @@ -1,13 +1,14 @@ -# 00gnulib.m4 serial 3 +# 00gnulib.m4 serial 7 dnl Copyright (C) 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. dnl This file must be named something that sorts before all other -dnl gnulib-provided .m4 files. It is needed until such time as we can -dnl assume Autoconf 2.64, with its improved AC_DEFUN_ONCE and -dnl m4_divert semantics. +dnl gnulib-provided .m4 files. The first part is needed until such time +dnl as we can assume Autoconf 2.64, with its improved AC_DEFUN_ONCE and +dnl m4_divert semantics. The second part is needed until the clang fix +dnl has been included in Autoconf. # Until autoconf 2.63, handling of the diversion stack required m4_init # to be called first; but this does not happen with aclocal. Wrapping @@ -39,6 +40,76 @@ m4_version_prereq([2.63.263], [], [m4_indir([_gl_DEFUN_ONCE([$1])])])])]dnl [AC][_DEFUN([_gl_DEFUN_ONCE([$1])], [$2])])]) +# The following definitions arrange to use a compiler option +# -Werror=implicit-function-declaration in AC_CHECK_DECL, when the +# compiler is clang. Without it, clang implicitly declares "known" +# library functions in C mode, but not in C++ mode, which would cause +# Gnulib to omit a declaration and thus later produce an error in C++ +# mode. As of clang 9.0, these "known" functions are identified through +# LIBBUILTIN invocations in the LLVM source file +# llvm/tools/clang/include/clang/Basic/Builtins.def. +# It's not possible to AC_REQUIRE the extra tests from AC_CHECK_DECL, +# because AC_CHECK_DECL, like other Autoconf built-ins, is not supposed +# to AC_REQUIRE anything: some configure.ac files have their first +# AC_CHECK_DECL executed conditionally. Therefore append the extra tests +# to AC_PROG_CC. +AC_DEFUN([gl_COMPILER_CLANG], +[ +dnl AC_REQUIRE([AC_PROG_CC]) + AC_CACHE_CHECK([whether the compiler is clang], + [gl_cv_compiler_clang], + [dnl Use _AC_COMPILE_IFELSE instead of AC_EGREP_CPP, to avoid error + dnl "circular dependency of AC_LANG_COMPILER(C)" if AC_PROG_CC has + dnl not yet been invoked. + _AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM([[ + #ifdef __clang__ + barfbarf + #endif + ]],[[]]) + ], + [gl_cv_compiler_clang=no], + [gl_cv_compiler_clang=yes]) + ]) +]) +AC_DEFUN([gl_COMPILER_PREPARE_CHECK_DECL], +[ +dnl AC_REQUIRE([AC_PROG_CC]) +dnl AC_REQUIRE([gl_COMPILER_CLANG]) + AC_CACHE_CHECK([for compiler option needed when checking for declarations], + [gl_cv_compiler_check_decl_option], + [if test $gl_cv_compiler_clang = yes; then + dnl Test whether the compiler supports the option + dnl '-Werror=implicit-function-declaration'. + save_ac_compile="$ac_compile" + ac_compile="$ac_compile -Werror=implicit-function-declaration" + dnl Use _AC_COMPILE_IFELSE instead of AC_COMPILE_IFELSE, to avoid a + dnl warning "AC_COMPILE_IFELSE was called before AC_USE_SYSTEM_EXTENSIONS". + _AC_COMPILE_IFELSE([AC_LANG_PROGRAM([[]],[[]])], + [gl_cv_compiler_check_decl_option='-Werror=implicit-function-declaration'], + [gl_cv_compiler_check_decl_option=none]) + ac_compile="$save_ac_compile" + else + gl_cv_compiler_check_decl_option=none + fi + ]) + if test "x$gl_cv_compiler_check_decl_option" != xnone; then + ac_compile_for_check_decl="$ac_compile $gl_cv_compiler_check_decl_option" + else + ac_compile_for_check_decl="$ac_compile" + fi +]) +dnl Redefine _AC_CHECK_DECL_BODY so that it references ac_compile_for_check_decl +dnl instead of ac_compile. If, for whatever reason, the override of AC_PROG_CC +dnl in zzgnulib.m4 is inactive, use the original ac_compile. +m4_define([_AC_CHECK_DECL_BODY], +[ ac_save_ac_compile="$ac_compile" + if test -n "$ac_compile_for_check_decl"; then + ac_compile="$ac_compile_for_check_decl" + fi] +m4_defn([_AC_CHECK_DECL_BODY])[ ac_compile="$ac_save_ac_compile" +]) + # gl_00GNULIB # ----------- # Witness macro that this file has been included. Needed to force diff --git a/m4/acl.m4 b/m4/acl.m4 index e459451ae31..a3dcf9357b9 100644 --- a/m4/acl.m4 +++ b/m4/acl.m4 @@ -1,5 +1,5 @@ # acl.m4 - check for access control list (ACL) primitives -# serial 23 +# serial 24 # Copyright (C) 2002, 2004-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation @@ -139,7 +139,7 @@ int type = ACL_TYPE_EXTENDED;]])], AC_MSG_WARN([AC_PACKAGE_NAME will be built without ACL support.]) fi fi - test $gl_need_lib_has_acl && LIB_HAS_ACL=$LIB_ACL + test -n "$gl_need_lib_has_acl" && LIB_HAS_ACL=$LIB_ACL AC_SUBST([LIB_ACL]) AC_DEFINE_UNQUOTED([USE_ACL], [$use_acl], [Define to nonzero if you want access control list support.]) diff --git a/m4/alloca.m4 b/m4/alloca.m4 index 5f4653967d1..59225245b91 100644 --- a/m4/alloca.m4 +++ b/m4/alloca.m4 @@ -1,6 +1,6 @@ # alloca.m4 serial 15 -dnl Copyright (C) 2002-2004, 2006-2007, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2004, 2006-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/count-leading-zeros.m4 b/m4/count-leading-zeros.m4 deleted file mode 100644 index 76cc876f296..00000000000 --- a/m4/count-leading-zeros.m4 +++ /dev/null @@ -1,12 +0,0 @@ -# count-leading-zeros.m4 serial 2 -dnl Copyright (C) 2012-2020 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -AC_DEFUN([gl_COUNT_LEADING_ZEROS], -[ - dnl We don't need (and can't compile) count_leading_zeros_ll - dnl unless the type 'unsigned long long int' exists. - AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) -]) diff --git a/m4/count-one-bits.m4 b/m4/count-one-bits.m4 deleted file mode 100644 index 132d52761f0..00000000000 --- a/m4/count-one-bits.m4 +++ /dev/null @@ -1,12 +0,0 @@ -# count-one-bits.m4 serial 3 -dnl Copyright (C) 2007, 2009-2020 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -AC_DEFUN([gl_COUNT_ONE_BITS], -[ - dnl We don't need (and can't compile) count_one_bits_ll - dnl unless the type 'unsigned long long int' exists. - AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) -]) diff --git a/m4/count-trailing-zeros.m4 b/m4/count-trailing-zeros.m4 deleted file mode 100644 index 0344c8ffa50..00000000000 --- a/m4/count-trailing-zeros.m4 +++ /dev/null @@ -1,12 +0,0 @@ -# count-trailing-zeros.m4 -dnl Copyright (C) 2013-2020 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -AC_DEFUN([gl_COUNT_TRAILING_ZEROS], -[ - dnl We don't need (and can't compile) count_trailing_zeros_ll - dnl unless the type 'unsigned long long int' exists. - AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) -]) diff --git a/m4/d-type.m4 b/m4/d-type.m4 index bcb179ad4e1..d40220a1b59 100644 --- a/m4/d-type.m4 +++ b/m4/d-type.m4 @@ -5,8 +5,7 @@ dnl dnl Check whether struct dirent has a member named d_type. dnl -# Copyright (C) 1997, 1999-2004, 2006, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 1997, 1999-2004, 2006, 2009-2020 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/dup2.m4 b/m4/dup2.m4 index 2835bb1cf99..462bfd0e526 100644 --- a/m4/dup2.m4 +++ b/m4/dup2.m4 @@ -1,6 +1,5 @@ -#serial 25 -dnl Copyright (C) 2002, 2005, 2007, 2009-2020 Free Software Foundation, -dnl Inc. +#serial 26 +dnl Copyright (C) 2002, 2005, 2007, 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -9,107 +8,94 @@ AC_DEFUN([gl_FUNC_DUP2], [ AC_REQUIRE([gl_UNISTD_H_DEFAULTS]) AC_REQUIRE([AC_CANONICAL_HOST]) - m4_ifdef([gl_FUNC_DUP2_OBSOLETE], [ - AC_CHECK_FUNCS_ONCE([dup2]) - if test $ac_cv_func_dup2 = no; then - HAVE_DUP2=0 - fi - ], [ - AC_DEFINE([HAVE_DUP2], [1], [Define to 1 if you have the 'dup2' function.]) - ]) - if test $HAVE_DUP2 = 1; then - AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], - [AC_RUN_IFELSE([ - AC_LANG_PROGRAM( - [[#include <errno.h> - #include <fcntl.h> - #include <limits.h> - #include <sys/resource.h> - #include <unistd.h> - #ifndef RLIM_SAVED_CUR - # define RLIM_SAVED_CUR RLIM_INFINITY - #endif - #ifndef RLIM_SAVED_MAX - # define RLIM_SAVED_MAX RLIM_INFINITY - #endif - ]], - [[int result = 0; - int bad_fd = INT_MAX; - struct rlimit rlim; - if (getrlimit (RLIMIT_NOFILE, &rlim) == 0 - && 0 <= rlim.rlim_cur && rlim.rlim_cur <= INT_MAX - && rlim.rlim_cur != RLIM_INFINITY - && rlim.rlim_cur != RLIM_SAVED_MAX - && rlim.rlim_cur != RLIM_SAVED_CUR) - bad_fd = rlim.rlim_cur; - #ifdef FD_CLOEXEC - if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) - result |= 1; - #endif - if (dup2 (1, 1) != 1) - result |= 2; - #ifdef FD_CLOEXEC - if (fcntl (1, F_GETFD) != FD_CLOEXEC) - result |= 4; - #endif - close (0); - if (dup2 (0, 0) != -1) - result |= 8; - /* Many gnulib modules require POSIX conformance of EBADF. */ - if (dup2 (2, bad_fd) == -1 && errno != EBADF) - result |= 16; - /* Flush out some cygwin core dumps. */ - if (dup2 (2, -1) != -1 || errno != EBADF) - result |= 32; - dup2 (2, 255); - dup2 (2, 256); - /* On OS/2 kLIBC, dup2() does not work on a directory fd. */ - { - int fd = open (".", O_RDONLY); - if (fd == -1) - result |= 64; - else if (dup2 (fd, fd + 1) == -1) - result |= 128; - - close (fd); - } - return result;]]) - ], - [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], - [case "$host_os" in - mingw*) # on this platform, dup2 always returns 0 for success - gl_cv_func_dup2_works="guessing no" ;; - cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 - gl_cv_func_dup2_works="guessing no" ;; - aix* | freebsd*) - # on AIX 7.1 and FreeBSD 6.1, dup2 (1,toobig) gives EMFILE, - # not EBADF. - gl_cv_func_dup2_works="guessing no" ;; - haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. - gl_cv_func_dup2_works="guessing no" ;; - *-android*) # implemented using dup3(), which fails if oldfd == newfd - gl_cv_func_dup2_works="guessing no" ;; - os2*) # on OS/2 kLIBC, dup2() does not work on a directory fd. - gl_cv_func_dup2_works="guessing no" ;; - *) gl_cv_func_dup2_works="guessing yes" ;; - esac]) - ]) - case "$gl_cv_func_dup2_works" in - *yes) ;; - *) - REPLACE_DUP2=1 - AC_CHECK_FUNCS([setdtablesize]) - ;; - esac - fi + AC_CACHE_CHECK([whether dup2 works], [gl_cv_func_dup2_works], + [AC_RUN_IFELSE([ + AC_LANG_PROGRAM( + [[#include <errno.h> + #include <fcntl.h> + #include <limits.h> + #include <sys/resource.h> + #include <unistd.h> + #ifndef RLIM_SAVED_CUR + # define RLIM_SAVED_CUR RLIM_INFINITY + #endif + #ifndef RLIM_SAVED_MAX + # define RLIM_SAVED_MAX RLIM_INFINITY + #endif + ]], + [[int result = 0; + int bad_fd = INT_MAX; + struct rlimit rlim; + if (getrlimit (RLIMIT_NOFILE, &rlim) == 0 + && 0 <= rlim.rlim_cur && rlim.rlim_cur <= INT_MAX + && rlim.rlim_cur != RLIM_INFINITY + && rlim.rlim_cur != RLIM_SAVED_MAX + && rlim.rlim_cur != RLIM_SAVED_CUR) + bad_fd = rlim.rlim_cur; + #ifdef FD_CLOEXEC + if (fcntl (1, F_SETFD, FD_CLOEXEC) == -1) + result |= 1; + #endif + if (dup2 (1, 1) != 1) + result |= 2; + #ifdef FD_CLOEXEC + if (fcntl (1, F_GETFD) != FD_CLOEXEC) + result |= 4; + #endif + close (0); + if (dup2 (0, 0) != -1) + result |= 8; + /* Many gnulib modules require POSIX conformance of EBADF. */ + if (dup2 (2, bad_fd) == -1 && errno != EBADF) + result |= 16; + /* Flush out some cygwin core dumps. */ + if (dup2 (2, -1) != -1 || errno != EBADF) + result |= 32; + dup2 (2, 255); + dup2 (2, 256); + /* On OS/2 kLIBC, dup2() does not work on a directory fd. */ + { + int fd = open (".", O_RDONLY); + if (fd == -1) + result |= 64; + else if (dup2 (fd, fd + 1) == -1) + result |= 128; + close (fd); + } + return result;]]) + ], + [gl_cv_func_dup2_works=yes], [gl_cv_func_dup2_works=no], + [case "$host_os" in + mingw*) # on this platform, dup2 always returns 0 for success + gl_cv_func_dup2_works="guessing no" ;; + cygwin*) # on cygwin 1.5.x, dup2(1,1) returns 0 + gl_cv_func_dup2_works="guessing no" ;; + aix* | freebsd*) + # on AIX 7.1 and FreeBSD 6.1, dup2 (1,toobig) gives EMFILE, + # not EBADF. + gl_cv_func_dup2_works="guessing no" ;; + haiku*) # on Haiku alpha 2, dup2(1, 1) resets FD_CLOEXEC. + gl_cv_func_dup2_works="guessing no" ;; + *-android*) # implemented using dup3(), which fails if oldfd == newfd + gl_cv_func_dup2_works="guessing no" ;; + os2*) # on OS/2 kLIBC, dup2() does not work on a directory fd. + gl_cv_func_dup2_works="guessing no" ;; + *) gl_cv_func_dup2_works="guessing yes" ;; + esac]) + ]) + case "$gl_cv_func_dup2_works" in + *yes) ;; + *) + REPLACE_DUP2=1 + AC_CHECK_FUNCS([setdtablesize]) + ;; + esac dnl Replace dup2() for supporting the gnulib-defined fchdir() function, dnl to keep fchdir's bookkeeping up-to-date. m4_ifdef([gl_FUNC_FCHDIR], [ gl_TEST_FCHDIR if test $HAVE_FCHDIR = 0; then - if test $HAVE_DUP2 = 1; then - REPLACE_DUP2=1 - fi + REPLACE_DUP2=1 fi ]) ]) diff --git a/m4/explicit_bzero.m4 b/m4/explicit_bzero.m4 index 507816affdb..a415e7b4f5e 100644 --- a/m4/explicit_bzero.m4 +++ b/m4/explicit_bzero.m4 @@ -19,4 +19,5 @@ AC_DEFUN([gl_FUNC_EXPLICIT_BZERO], AC_DEFUN([gl_PREREQ_EXPLICIT_BZERO], [ AC_CHECK_FUNCS([explicit_memset]) + AC_CHECK_FUNCS_ONCE([memset_s]) ]) diff --git a/m4/fchmodat.m4 b/m4/fchmodat.m4 new file mode 100644 index 00000000000..e3f2f048162 --- /dev/null +++ b/m4/fchmodat.m4 @@ -0,0 +1,82 @@ +# fchmodat.m4 serial 4 +dnl Copyright (C) 2004-2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# Written by Jim Meyering. + +AC_DEFUN([gl_FUNC_FCHMODAT], +[ + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_CHECK_FUNCS_ONCE([fchmodat lchmod]) + if test $ac_cv_func_fchmodat != yes; then + HAVE_FCHMODAT=0 + else + AC_CACHE_CHECK( + [whether fchmodat+AT_SYMLINK_NOFOLLOW works on non-symlinks], + [gl_cv_func_fchmodat_works], + [dnl This test fails on GNU/Linux with glibc 2.31 (but not on + dnl GNU/kFreeBSD nor GNU/Hurd) and Cygwin 2.9. + AC_RUN_IFELSE( + [AC_LANG_PROGRAM( + [ + AC_INCLUDES_DEFAULT[ + #include <fcntl.h> + #ifndef S_IRUSR + #define S_IRUSR 0400 + #endif + #ifndef S_IWUSR + #define S_IWUSR 0200 + #endif + #ifndef S_IRWXU + #define S_IRWXU 0700 + #endif + #ifndef S_IRWXG + #define S_IRWXG 0070 + #endif + #ifndef S_IRWXO + #define S_IRWXO 0007 + #endif + ]], + [[ + int permissive = S_IRWXU | S_IRWXG | S_IRWXO; + int desired = S_IRUSR | S_IWUSR; + static char const f[] = "conftest.fchmodat"; + struct stat st; + if (creat (f, permissive) < 0) + return 1; + if (fchmodat (AT_FDCWD, f, desired, AT_SYMLINK_NOFOLLOW) != 0) + return 1; + if (stat (f, &st) != 0) + return 1; + return ! ((st.st_mode & permissive) == desired); + ]])], + [gl_cv_func_fchmodat_works=yes], + [gl_cv_func_fchmodat_works=no], + [case "$host_os" in + dnl Guess no on Linux with glibc and Cygwin, yes otherwise. + linux-gnu* | cygwin*) gl_cv_func_fchmodat_works="guessing no" ;; + *) gl_cv_func_fchmodat_works="$gl_cross_guess_normal" ;; + esac + ]) + rm -f conftest.fchmodat]) + case $gl_cv_func_fchmodat_works in + *yes) ;; + *) + AC_DEFINE([NEED_FCHMODAT_NONSYMLINK_FIX], [1], + [Define to 1 if fchmodat+AT_SYMLINK_NOFOLLOW does not work right on non-symlinks.]) + REPLACE_FCHMODAT=1 + ;; + esac + fi +]) + +# Prerequisites of lib/fchmodat.c. +AC_DEFUN([gl_PREREQ_FCHMODAT], +[ + AC_CHECK_FUNCS_ONCE([lchmod]) + : +]) diff --git a/m4/filemode.m4 b/m4/filemode.m4 index a1b7e105b59..5aaaa1a167d 100644 --- a/m4/filemode.m4 +++ b/m4/filemode.m4 @@ -1,6 +1,5 @@ # filemode.m4 serial 8 -dnl Copyright (C) 2002, 2005-2006, 2009-2020 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/fsusage.m4 b/m4/fsusage.m4 index 64fcf5d290d..0bc62066aab 100644 --- a/m4/fsusage.m4 +++ b/m4/fsusage.m4 @@ -1,8 +1,7 @@ # serial 34 # Obtaining file system usage information. -# Copyright (C) 1997-1998, 2000-2001, 2003-2020 Free Software -# Foundation, Inc. +# Copyright (C) 1997-1998, 2000-2001, 2003-2020 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/futimens.m4 b/m4/futimens.m4 new file mode 100644 index 00000000000..dc5cfa94119 --- /dev/null +++ b/m4/futimens.m4 @@ -0,0 +1,65 @@ +# serial 8 +# See if we need to provide futimens replacement. + +dnl Copyright (C) 2009-2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# Written by Eric Blake. + +AC_DEFUN([gl_FUNC_FUTIMENS], +[ + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_CHECK_FUNCS_ONCE([futimens]) + if test $ac_cv_func_futimens = no; then + HAVE_FUTIMENS=0 + else + AC_CACHE_CHECK([whether futimens works], + [gl_cv_func_futimens_works], + [AC_RUN_IFELSE([AC_LANG_PROGRAM([[ +#include <fcntl.h> +#include <sys/stat.h> +#include <unistd.h> +#include <errno.h> +]], [[struct timespec ts[2]; + int fd = creat ("conftest.file", 0600); + struct stat st; + if (fd < 0) return 1; + ts[0].tv_sec = 1; + ts[0].tv_nsec = UTIME_OMIT; + ts[1].tv_sec = 1; + ts[1].tv_nsec = UTIME_NOW; + errno = 0; + if (futimens (AT_FDCWD, NULL) == 0) return 2; + if (errno != EBADF) return 3; + if (futimens (fd, ts)) return 4; + sleep (1); + ts[0].tv_nsec = UTIME_NOW; + ts[1].tv_nsec = UTIME_OMIT; + if (futimens (fd, ts)) return 5; + if (fstat (fd, &st)) return 6; + if (st.st_ctime < st.st_atime) return 7; + ]])], + [gl_cv_func_futimens_works=yes], + [gl_cv_func_futimens_works=no], + [case "$host_os" in + # Guess no on glibc systems. + *-gnu* | gnu*) gl_cv_func_futimens_works="guessing no" ;; + # Guess no on musl systems. + *-musl*) gl_cv_func_futimens_works="guessing no" ;; + # Guess yes otherwise. + *) gl_cv_func_futimens_works="guessing yes" ;; + esac + ]) + rm -f conftest.file]) + case "$gl_cv_func_futimens_works" in + *yes) ;; + *) + REPLACE_FUTIMENS=1 + ;; + esac + fi +]) diff --git a/m4/getgroups.m4 b/m4/getgroups.m4 index 79436460f30..3e7e46f8672 100644 --- a/m4/getgroups.m4 +++ b/m4/getgroups.m4 @@ -3,8 +3,7 @@ dnl From Jim Meyering. dnl A wrapper around AC_FUNC_GETGROUPS. -# Copyright (C) 1996-1997, 1999-2004, 2008-2020 Free Software -# Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2004, 2008-2020 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/getloadavg.m4 b/m4/getloadavg.m4 index 74a116fd10d..8e96965d828 100644 --- a/m4/getloadavg.m4 +++ b/m4/getloadavg.m4 @@ -1,13 +1,13 @@ # Check for getloadavg. -# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2020 Free -# Software Foundation, Inc. +# Copyright (C) 1992-1996, 1999-2000, 2002-2003, 2006, 2008-2020 Free Software +# Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. -#serial 8 +#serial 9 # Autoconf defines AC_FUNC_GETLOADAVG, but that is obsolescent. # New applications should use gl_GETLOADAVG instead. @@ -45,7 +45,9 @@ AC_CHECK_FUNC([getloadavg], [], # There is a commonly available library for RS/6000 AIX. # Since it is not a standard part of AIX, it might be installed locally. gl_getloadavg_LIBS=$LIBS - LIBS="-L/usr/local/lib $LIBS" + if test $cross_compiling != yes; then + LIBS="-L/usr/local/lib $LIBS" + fi AC_CHECK_LIB([getloadavg], [getloadavg], [LIBS="-lgetloadavg $LIBS" gl_func_getloadavg_done=yes], [LIBS=$gl_getloadavg_LIBS]) diff --git a/m4/getrandom.m4 b/m4/getrandom.m4 new file mode 100644 index 00000000000..424c2fad3e3 --- /dev/null +++ b/m4/getrandom.m4 @@ -0,0 +1,67 @@ +# getrandom.m4 serial 7 +dnl Copyright 2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl Written by Paul Eggert. + +AC_DEFUN([gl_FUNC_GETRANDOM], +[ + AC_REQUIRE([gl_SYS_RANDOM_H_DEFAULTS]) + AC_CHECK_FUNCS_ONCE([getrandom]) + if test "$ac_cv_func_getrandom" != yes; then + HAVE_GETRANDOM=0 + else + dnl On Solaris 11.4 the return type is 'int', not 'ssize_t'. + AC_CACHE_CHECK([whether getrandom is compatible with its GNU+BSD signature], + [gl_cv_func_getrandom_ok], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[/* Additional includes are needed before <sys/random.h> on Mac OS X. */ + #include <sys/types.h> + #include <stdlib.h> + #include <sys/random.h> + ssize_t getrandom (void *, size_t, unsigned int); + ]], + [[]]) + ], + [gl_cv_func_getrandom_ok=yes], + [gl_cv_func_getrandom_ok=no]) + ]) + if test $gl_cv_func_getrandom_ok = no; then + REPLACE_GETRANDOM=1 + fi + fi + + case "$host_os" in + mingw*) + AC_CHECK_HEADERS([bcrypt.h], [], [], + [[#include <windows.h> + ]]) + AC_CACHE_CHECK([whether the bcrypt library is guaranteed to be present], + [gl_cv_lib_assume_bcrypt], + [AC_COMPILE_IFELSE( + [AC_LANG_PROGRAM( + [[#include <windows.h>]], + [[#if !(_WIN32_WINNT >= _WIN32_WINNT_WIN7) + cannot assume it + #endif + ]]) + ], + [gl_cv_lib_assume_bcrypt=yes], + [gl_cv_lib_assume_bcrypt=no]) + ]) + if test $gl_cv_lib_assume_bcrypt = yes; then + AC_DEFINE([HAVE_LIB_BCRYPT], [1], + [Define to 1 if the bcrypt library is guaranteed to be present.]) + LIB_GETRANDOM='-lbcrypt' + else + LIB_GETRANDOM='-ladvapi32' + fi + ;; + *) + LIB_GETRANDOM= ;; + esac + AC_SUBST([LIB_GETRANDOM]) +]) diff --git a/m4/gettime.m4 b/m4/gettime.m4 index 6a1f9a4157d..e65455a2ff9 100644 --- a/m4/gettime.m4 +++ b/m4/gettime.m4 @@ -1,6 +1,5 @@ # gettime.m4 serial 9 -dnl Copyright (C) 2002, 2004-2006, 2009-2020 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2004-2006, 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gettimeofday.m4 b/m4/gettimeofday.m4 index 443c6f9309a..c72b3eacc63 100644 --- a/m4/gettimeofday.m4 +++ b/m4/gettimeofday.m4 @@ -1,7 +1,6 @@ # serial 27 -# Copyright (C) 2001-2003, 2005, 2007, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 2001-2003, 2005, 2007, 2009-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/glibc21.m4 b/m4/glibc21.m4 index 9197d3bf45f..ece484b5ae9 100644 --- a/m4/glibc21.m4 +++ b/m4/glibc21.m4 @@ -1,6 +1,6 @@ # glibc21.m4 serial 5 -dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2000-2002, 2004, 2008, 2010-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/gnulib-common.m4 b/m4/gnulib-common.m4 index b617eacff01..f4ba5e3a00d 100644 --- a/m4/gnulib-common.m4 +++ b/m4/gnulib-common.m4 @@ -1,4 +1,4 @@ -# gnulib-common.m4 serial 46 +# gnulib-common.m4 serial 50 dnl Copyright (C) 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -12,8 +12,18 @@ AC_DEFUN([gl_COMMON], [ dnl Use AC_REQUIRE here, so that the code is expanded once only. AC_REQUIRE([gl_00GNULIB]) AC_REQUIRE([gl_COMMON_BODY]) + AC_REQUIRE([gl_ZZGNULIB]) ]) AC_DEFUN([gl_COMMON_BODY], [ + AH_VERBATIM([_GL_GNUC_PREREQ], +[/* True if the compiler says it groks GNU C version MAJOR.MINOR. */ +#if defined __GNUC__ && defined __GNUC_MINOR__ +# define _GL_GNUC_PREREQ(major, minor) \ + ((major) < __GNUC__ + ((minor) <= __GNUC_MINOR__)) +#else +# define _GL_GNUC_PREREQ(major, minor) 0 +#endif +]) AH_VERBATIM([_Noreturn], [/* The _Noreturn keyword of C11. */ #ifndef _Noreturn @@ -30,9 +40,12 @@ AC_DEFUN([gl_COMMON_BODY], [ # define _Noreturn [[noreturn]] # elif ((!defined __cplusplus || defined __clang__) \ && (201112 <= (defined __STDC_VERSION__ ? __STDC_VERSION__ : 0) \ - || 4 < __GNUC__ + (7 <= __GNUC_MINOR__))) + || _GL_GNUC_PREREQ (4, 7) \ + || (defined __apple_build_version__ \ + ? 6000000 <= __apple_build_version__ \ + : 3 < __clang_major__ + (5 <= __clang_minor__)))) /* _Noreturn works as-is. */ -# elif 2 < __GNUC__ + (8 <= __GNUC_MINOR__) || 0x5110 <= __SUNPRO_C +# elif _GL_GNUC_PREREQ (2, 8) || 0x5110 <= __SUNPRO_C # define _Noreturn __attribute__ ((__noreturn__)) # elif 1200 <= (defined _MSC_VER ? _MSC_VER : 0) # define _Noreturn __declspec (noreturn) @@ -51,48 +64,206 @@ AC_DEFUN([gl_COMMON_BODY], [ #if defined __APPLE__ && defined __MACH__ && __APPLE_CC__ >= 5465 && !defined __cplusplus && __STDC_VERSION__ >= 199901L && !defined __GNUC_STDC_INLINE__ # define __GNUC_STDC_INLINE__ 1 #endif]) - AH_VERBATIM([unused_parameter], -[/* Define as a marker that can be attached to declarations that might not - be used. This helps to reduce warnings, such as from - GCC -Wunused-parameter. */ -#if __GNUC__ >= 3 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 7) -# define _GL_UNUSED __attribute__ ((__unused__)) + AH_VERBATIM([attribute], +[/* Attributes. */ +#ifdef __has_attribute +# define _GL_HAS_ATTRIBUTE(attr) __has_attribute (__##attr##__) #else -# define _GL_UNUSED +# define _GL_HAS_ATTRIBUTE(attr) _GL_ATTR_##attr +# define _GL_ATTR_alloc_size _GL_GNUC_PREREQ (4, 3) +# define _GL_ATTR_always_inline _GL_GNUC_PREREQ (3, 2) +# define _GL_ATTR_artificial _GL_GNUC_PREREQ (4, 3) +# define _GL_ATTR_cold _GL_GNUC_PREREQ (4, 3) +# define _GL_ATTR_const _GL_GNUC_PREREQ (2, 95) +# define _GL_ATTR_deprecated _GL_GNUC_PREREQ (3, 1) +# define _GL_ATTR_error _GL_GNUC_PREREQ (4, 3) +# define _GL_ATTR_externally_visible _GL_GNUC_PREREQ (4, 1) +# define _GL_ATTR_fallthrough _GL_GNUC_PREREQ (7, 0) +# define _GL_ATTR_format _GL_GNUC_PREREQ (2, 7) +# define _GL_ATTR_leaf _GL_GNUC_PREREQ (4, 6) +# ifdef _ICC +# define _GL_ATTR_may_alias 0 +# else +# define _GL_ATTR_may_alias _GL_GNUC_PREREQ (3, 3) +# endif +# define _GL_ATTR_malloc _GL_GNUC_PREREQ (3, 0) +# define _GL_ATTR_noinline _GL_GNUC_PREREQ (3, 1) +# define _GL_ATTR_nonnull _GL_GNUC_PREREQ (3, 3) +# define _GL_ATTR_nonstring _GL_GNUC_PREREQ (8, 0) +# define _GL_ATTR_nothrow _GL_GNUC_PREREQ (3, 3) +# define _GL_ATTR_packed _GL_GNUC_PREREQ (2, 7) +# define _GL_ATTR_pure _GL_GNUC_PREREQ (2, 96) +# define _GL_ATTR_returns_nonnull _GL_GNUC_PREREQ (4, 9) +# define _GL_ATTR_sentinel _GL_GNUC_PREREQ (4, 0) +# define _GL_ATTR_unused _GL_GNUC_PREREQ (2, 7) +# define _GL_ATTR_warn_unused_result _GL_GNUC_PREREQ (3, 4) #endif -/* The name _UNUSED_PARAMETER_ is an earlier spelling, although the name - is a misnomer outside of parameter lists. */ -#define _UNUSED_PARAMETER_ _GL_UNUSED - -/* gcc supports the "unused" attribute on possibly unused labels, and - g++ has since version 4.5. Note to support C++ as well as C, - _GL_UNUSED_LABEL should be used with a trailing ; */ -#if !defined __cplusplus || __GNUC__ > 4 \ - || (__GNUC__ == 4 && __GNUC_MINOR__ >= 5) -# define _GL_UNUSED_LABEL _GL_UNUSED + +]dnl There is no _GL_ATTRIBUTE_ALIGNED; use stdalign's _Alignas instead. +[ +#if _GL_HAS_ATTRIBUTE (alloc_size) +# define _GL_ATTRIBUTE_ALLOC_SIZE(args) __attribute__ ((__alloc_size__ args)) #else -# define _GL_UNUSED_LABEL +# define _GL_ATTRIBUTE_ALLOC_SIZE(args) #endif -/* The __pure__ attribute was added in gcc 2.96. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 96) -# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) +#if _GL_HAS_ATTRIBUTE (always_inline) +# define _GL_ATTRIBUTE_ALWAYS_INLINE __attribute__ ((__always_inline__)) #else -# define _GL_ATTRIBUTE_PURE /* empty */ +# define _GL_ATTRIBUTE_ALWAYS_INLINE #endif -/* The __const__ attribute was added in gcc 2.95. */ -#if __GNUC__ > 2 || (__GNUC__ == 2 && __GNUC_MINOR__ >= 95) +#if _GL_HAS_ATTRIBUTE (artificial) +# define _GL_ATTRIBUTE_ARTIFICIAL __attribute__ ((__artificial__)) +#else +# define _GL_ATTRIBUTE_ARTIFICIAL +#endif + +/* Avoid __attribute__ ((cold)) on MinGW; see thread starting at + <https://lists.gnu.org/r/emacs-devel/2019-04/msg01152.html>. */ +#if _GL_HAS_ATTRIBUTE (cold) && !defined __MINGW32__ +# define _GL_ATTRIBUTE_COLD __attribute__ ((__cold__)) +#else +# define _GL_ATTRIBUTE_COLD +#endif + +#if _GL_HAS_ATTRIBUTE (const) # define _GL_ATTRIBUTE_CONST __attribute__ ((__const__)) #else -# define _GL_ATTRIBUTE_CONST /* empty */ +# define _GL_ATTRIBUTE_CONST #endif -/* The __malloc__ attribute was added in gcc 3. */ -#if 3 <= __GNUC__ +#if 201710L < __STDC_VERSION__ +# define _GL_ATTRIBUTE_DEPRECATED [[__deprecated__]] +#elif _GL_HAS_ATTRIBUTE (deprecated) +# define _GL_ATTRIBUTE_DEPRECATED __attribute__ ((__deprecated__)) +#else +# define _GL_ATTRIBUTE_DEPRECATED +#endif + +#if _GL_HAS_ATTRIBUTE (error) +# define _GL_ATTRIBUTE_ERROR(msg) __attribute__ ((__error__ (msg))) +# define _GL_ATTRIBUTE_WARNING(msg) __attribute__ ((__warning__ (msg))) +#else +# define _GL_ATTRIBUTE_ERROR(msg) +# define _GL_ATTRIBUTE_WARNING(msg) +#endif + +#if _GL_HAS_ATTRIBUTE (externally_visible) +# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE __attribute__ ((externally_visible)) +#else +# define _GL_ATTRIBUTE_EXTERNALLY_VISIBLE +#endif + +/* FALLTHROUGH is special, because it always expands to something. */ +#if 201710L < __STDC_VERSION__ +# define _GL_ATTRIBUTE_FALLTHROUGH [[__fallthrough__]] +#elif _GL_HAS_ATTRIBUTE (fallthrough) +# define _GL_ATTRIBUTE_FALLTHROUGH __attribute__ ((__fallthrough__)) +#else +# define _GL_ATTRIBUTE_FALLTHROUGH ((void) 0) +#endif + +#if _GL_HAS_ATTRIBUTE (format) +# define _GL_ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) +#else +# define _GL_ATTRIBUTE_FORMAT(spec) +#endif + +#if _GL_HAS_ATTRIBUTE (leaf) +# define _GL_ATTRIBUTE_LEAF __attribute__ ((__leaf__)) +#else +# define _GL_ATTRIBUTE_LEAF +#endif + +#if _GL_HAS_ATTRIBUTE (may_alias) +# define _GL_ATTRIBUTE_MAY_ALIAS __attribute__ ((__may_alias__)) +#else +# define _GL_ATTRIBUTE_MAY_ALIAS +#endif + +#if 201710L < __STDC_VERSION__ +# define _GL_ATTRIBUTE_MAYBE_UNUSED [[__maybe_unused__]] +#elif _GL_HAS_ATTRIBUTE (unused) +# define _GL_ATTRIBUTE_MAYBE_UNUSED __attribute__ ((__unused__)) +#else +# define _GL_ATTRIBUTE_MAYBE_UNUSED +#endif +/* Earlier spellings of this macro. */ +#define _GL_UNUSED _GL_ATTRIBUTE_MAYBE_UNUSED +#define _UNUSED_PARAMETER_ _GL_ATTRIBUTE_MAYBE_UNUSED + +#if _GL_HAS_ATTRIBUTE (malloc) # define _GL_ATTRIBUTE_MALLOC __attribute__ ((__malloc__)) #else -# define _GL_ATTRIBUTE_MALLOC /* empty */ +# define _GL_ATTRIBUTE_MALLOC +#endif + +#if 201710L < __STDC_VERSION__ +# define _GL_ATTRIBUTE_NODISCARD [[__nodiscard__]] +#elif _GL_HAS_ATTRIBUTE (warn_unused_result) +# define _GL_ATTRIBUTE_NODISCARD __attribute__ ((__warn_unused_result__)) +#else +# define _GL_ATTRIBUTE_NODISCARD +#endif + +#if _GL_HAS_ATTRIBUTE (noinline) +# define _GL_ATTRIBUTE_NOINLINE __attribute__ ((__noinline__)) +#else +# define _GL_ATTRIBUTE_NOINLINE +#endif + +#if _GL_HAS_ATTRIBUTE (nonnull) +# define _GL_ATTRIBUTE_NONNULL(args) __attribute__ ((__nonnull__ args)) +#else +# define _GL_ATTRIBUTE_NONNULL(args) +#endif + +#if _GL_HAS_ATTRIBUTE (nonstring) +# define _GL_ATTRIBUTE_NONSTRING __attribute__ ((__nonstring__)) +#else +# define _GL_ATTRIBUTE_NONSTRING +#endif + +/* There is no _GL_ATTRIBUTE_NORETURN; use _Noreturn instead. */ + +#if _GL_HAS_ATTRIBUTE (nothrow) && !defined __cplusplus +# define _GL_ATTRIBUTE_NOTHROW __attribute__ ((__nothrow__)) +#else +# define _GL_ATTRIBUTE_NOTHROW +#endif + +#if _GL_HAS_ATTRIBUTE (packed) +# define _GL_ATTRIBUTE_PACKED __attribute__ ((__packed__)) +#else +# define _GL_ATTRIBUTE_PACKED +#endif + +#if _GL_HAS_ATTRIBUTE (pure) +# define _GL_ATTRIBUTE_PURE __attribute__ ((__pure__)) +#else +# define _GL_ATTRIBUTE_PURE +#endif + +#if _GL_HAS_ATTRIBUTE (returns_nonnull) +# define _GL_ATTRIBUTE_RETURNS_NONNULL __attribute__ ((__returns_nonnull__)) +#else +# define _GL_ATTRIBUTE_RETURNS_NONNULL +#endif + +#if _GL_HAS_ATTRIBUTE (sentinel) +# define _GL_ATTRIBUTE_SENTINEL(pos) __attribute__ ((__sentinel__ pos)) +#else +# define _GL_ATTRIBUTE_SENTINEL(pos) +#endif + +]dnl There is no _GL_ATTRIBUTE_VISIBILITY; see m4/visibility.m4 instead. +[ +/* To support C++ as well as C, use _GL_UNUSED_LABEL with trailing ';'. */ +#if !defined __cplusplus || _GL_GNUC_PREREQ (4, 5) +# define _GL_UNUSED_LABEL _GL_ATTRIBUTE_MAYBE_UNUSED +#else +# define _GL_UNUSED_LABEL #endif ]) AH_VERBATIM([async_safe], @@ -415,12 +586,13 @@ AC_DEFUN([AC_C_RESTRICT], nothing if this is not supported. Do not define if restrict is supported directly. */ #undef restrict -/* Work around a bug in Sun C++: it does not support _Restrict or - __restrict__, even though the corresponding Sun C compiler ends up with - "#define restrict _Restrict" or "#define restrict __restrict__" in the - previous line. Perhaps some future version of Sun C++ will work with - restrict; if so, hopefully it defines __RESTRICT like Sun C does. */ -#if defined __SUNPRO_CC && !defined __RESTRICT +/* Work around a bug in older versions of Sun C++, which did not + #define __restrict__ or support _Restrict or __restrict__ + even though the corresponding Sun C compiler ended up with + "#define restrict _Restrict" or "#define restrict __restrict__" + in the previous line. This workaround can be removed once + we assume Oracle Developer Studio 12.5 (2016) or later. */ +#if defined __SUNPRO_CC && !defined __RESTRICT && !defined __restrict__ # define _Restrict # define __restrict__ #endif]) diff --git a/m4/gnulib-comp.m4 b/m4/gnulib-comp.m4 index c952c9c956c..f577a6fa741 100644 --- a/m4/gnulib-comp.m4 +++ b/m4/gnulib-comp.m4 @@ -47,11 +47,13 @@ AC_DEFUN([gl_EARLY], # Code from module alloca-opt: # Code from module allocator: # Code from module at-internal: + # Code from module attribute: # Code from module binary-io: # Code from module builtin-expect: # Code from module byteswap: # Code from module c-ctype: # Code from module c-strcase: + # Code from module c99: # Code from module canonicalize-lgpl: # Code from module careadlinkat: # Code from module clock-time: @@ -69,7 +71,6 @@ AC_DEFUN([gl_EARLY], # Code from module diffseq: # Code from module dirent: # Code from module dirfd: - # Code from module dosname: # Code from module double-slash-root: # Code from module dtoastr: # Code from module dtotimespec: @@ -82,10 +83,12 @@ AC_DEFUN([gl_EARLY], # Code from module extensions: # Code from module extern-inline: # Code from module faccessat: + # Code from module fchmodat: # Code from module fcntl: # Code from module fcntl-h: # Code from module fdopendir: # Code from module filemode: + # Code from module filename: # Code from module filevercmp: # Code from module flexmember: # Code from module fpending: @@ -94,11 +97,13 @@ AC_DEFUN([gl_EARLY], # Code from module fstatat: # Code from module fsusage: # Code from module fsync: + # Code from module futimens: # Code from module getdtablesize: # Code from module getgroups: # Code from module getloadavg: # Code from module getopt-gnu: # Code from module getopt-posix: + # Code from module getrandom: # Code from module gettext-h: # Code from module gettime: # Code from module gettimeofday: @@ -111,7 +116,9 @@ AC_DEFUN([gl_EARLY], # Code from module inttypes-incomplete: # Code from module largefile: AC_REQUIRE([AC_SYS_LARGEFILE]) + # Code from module lchmod: # Code from module libc-config: + # Code from module libgmp: # Code from module limits-h: # Code from module localtime-buffer: # Code from module lstat: @@ -133,7 +140,6 @@ AC_DEFUN([gl_EARLY], # Code from module pipe2: # Code from module pselect: # Code from module pthread_sigmask: - # Code from module putenv: # Code from module qcopy-acl: # Code from module readlink: # Code from module readlinkat: @@ -160,6 +166,7 @@ AC_DEFUN([gl_EARLY], # Code from module strtoimax: # Code from module strtoll: # Code from module symlink: + # Code from module sys_random: # Code from module sys_select: # Code from module sys_stat: # Code from module sys_time: @@ -178,6 +185,7 @@ AC_DEFUN([gl_EARLY], # Code from module unlocked-io: # Code from module update-copyright: # Code from module utimens: + # Code from module utimensat: # Code from module vararrays: # Code from module verify: # Code from module vla: @@ -212,6 +220,7 @@ AC_DEFUN([gl_INIT], gl_MODULE_INDICATOR([canonicalize-lgpl]) gl_STDLIB_MODULE_INDICATOR([canonicalize_file_name]) gl_STDLIB_MODULE_INDICATOR([realpath]) + AC_REQUIRE([AC_C_RESTRICT]) AC_CHECK_FUNCS_ONCE([readlinkat]) gl_CLOCK_TIME gl_MODULE_INDICATOR([close-stream]) @@ -220,18 +229,19 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([copy-file-range]) fi gl_UNISTD_MODULE_INDICATOR([copy-file-range]) - gl_COUNT_LEADING_ZEROS - gl_COUNT_ONE_BITS - gl_COUNT_TRAILING_ZEROS + AC_REQUIRE([AC_C_RESTRICT]) gl_MD5 + AC_REQUIRE([AC_C_RESTRICT]) gl_SHA1 + AC_REQUIRE([AC_C_RESTRICT]) gl_SHA256 + AC_REQUIRE([AC_C_RESTRICT]) gl_SHA512 gl_CHECK_TYPE_STRUCT_DIRENT_D_TYPE gl_DIRENT_H gl_DOUBLE_SLASH_ROOT gl_FUNC_DUP2 - if test $HAVE_DUP2 = 0 || test $REPLACE_DUP2 = 1; then + if test $REPLACE_DUP2 = 1; then AC_LIBOBJ([dup2]) gl_PREREQ_DUP2 fi @@ -254,6 +264,12 @@ AC_DEFUN([gl_INIT], fi gl_MODULE_INDICATOR([faccessat]) gl_UNISTD_MODULE_INDICATOR([faccessat]) + gl_FUNC_FCHMODAT + if test $HAVE_FCHMODAT = 0 || test $REPLACE_FCHMODAT = 1; then + AC_LIBOBJ([fchmodat]) + gl_PREREQ_FCHMODAT + fi + gl_SYS_STAT_MODULE_INDICATOR([fchmodat]) gl_FUNC_FCNTL if test $HAVE_FCNTL = 0 || test $REPLACE_FCNTL = 1; then AC_LIBOBJ([fcntl]) @@ -288,6 +304,12 @@ AC_DEFUN([gl_INIT], gl_PREREQ_FSYNC fi gl_UNISTD_MODULE_INDICATOR([fsync]) + gl_FUNC_FUTIMENS + if test $HAVE_FUTIMENS = 0 || test $REPLACE_FUTIMENS = 1; then + AC_LIBOBJ([futimens]) + fi + gl_SYS_STAT_MODULE_INDICATOR([futimens]) + AC_REQUIRE([AC_CANONICAL_HOST]) gl_GETLOADAVG if test $HAVE_GETLOADAVG = 0; then AC_LIBOBJ([getloadavg]) @@ -306,6 +328,13 @@ AC_DEFUN([gl_INIT], GNULIB_GL_UNISTD_H_GETOPT=1 fi AC_SUBST([GNULIB_GL_UNISTD_H_GETOPT]) + gl_UNISTD_MODULE_INDICATOR([getopt-posix]) + AC_REQUIRE([AC_CANONICAL_HOST]) + gl_FUNC_GETRANDOM + if test $HAVE_GETRANDOM = 0 || test $REPLACE_GETRANDOM = 1; then + AC_LIBOBJ([getrandom]) + fi + gl_SYS_RANDOM_MODULE_INDICATOR([getrandom]) gl_GETTIME gl_FUNC_GETTIMEOFDAY if test $HAVE_GETTIMEOFDAY = 0 || test $REPLACE_GETTIMEOFDAY = 1; then @@ -316,6 +345,11 @@ AC_DEFUN([gl_INIT], gl_IEEE754_H gl_INTTYPES_INCOMPLETE AC_REQUIRE([gl_LARGEFILE]) + gl___INLINE + gl_LIBGMP + if test -n "$GMP_H"; then + AC_LIBOBJ([mini-gmp-gnulib]) + fi gl_LIMITS_H gl_FUNC_LSTAT if test $REPLACE_LSTAT = 1; then @@ -370,12 +404,6 @@ AC_DEFUN([gl_INIT], gl_PREREQ_PTHREAD_SIGMASK fi gl_SIGNAL_MODULE_INDICATOR([pthread_sigmask]) - gl_FUNC_PUTENV - if test $REPLACE_PUTENV = 1; then - AC_LIBOBJ([putenv]) - gl_PREREQ_PUTENV - fi - gl_STDLIB_MODULE_INDICATOR([putenv]) gl_FUNC_READLINK if test $HAVE_READLINK = 0 || test $REPLACE_READLINK = 1; then AC_LIBOBJ([readlink]) @@ -431,6 +459,8 @@ AC_DEFUN([gl_INIT], AC_LIBOBJ([symlink]) fi gl_UNISTD_MODULE_INDICATOR([symlink]) + gl_HEADER_SYS_RANDOM + AC_PROG_MKDIR_P AC_REQUIRE([gl_HEADER_SYS_SELECT]) AC_PROG_MKDIR_P gl_HEADER_SYS_STAT_H @@ -440,6 +470,7 @@ AC_DEFUN([gl_INIT], gl_SYS_TYPES_H AC_PROG_MKDIR_P gl_FUNC_GEN_TEMPNAME + gl_MODULE_INDICATOR([tempname]) gl_HEADER_TIME_H gl_TIME_R if test $HAVE_LOCALTIME_R = 0 || test $REPLACE_LOCALTIME_R = 1; then @@ -462,7 +493,11 @@ AC_DEFUN([gl_INIT], gl_TIMESPEC gl_UNISTD_H gl_FUNC_GLIBC_UNLOCKED_IO - gl_UTIMENS + gl_FUNC_UTIMENSAT + if test $HAVE_UTIMENSAT = 0 || test $REPLACE_UTIMENSAT = 1; then + AC_LIBOBJ([utimensat]) + fi + gl_SYS_STAT_MODULE_INDICATOR([utimensat]) AC_C_VARARRAYS gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=false gl_gnulib_enabled_cloexec=false @@ -472,7 +507,7 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_getgroups=false gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36=false gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1=false - gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467=false + gl_gnulib_enabled_lchmod=false gl_gnulib_enabled_2049e887c7e5308faad27b3f894bb8c9=false gl_gnulib_enabled_malloca=false gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31=false @@ -480,13 +515,16 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_03e0aaad4cb89ca757653bd367a6ccb7=false gl_gnulib_enabled_6099e9737f757db36c47fa9d9f02e88c=false gl_gnulib_enabled_strtoll=false + gl_gnulib_enabled_utimens=false gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec=false func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b () { if ! $gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b; then - AC_LIBOBJ([openat-proc]) + AC_REQUIRE([AC_CANONICAL_HOST]) gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b=true - func_gl_gnulib_m4code_open + if case $host_os in mingw*) false;; *) :;; esac; then + func_gl_gnulib_m4code_open + fi fi } func_gl_gnulib_m4code_cloexec () @@ -574,11 +612,16 @@ AC_DEFUN([gl_INIT], fi fi } - func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467 () + func_gl_gnulib_m4code_lchmod () { - if ! $gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467; then - gl___INLINE - gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467=true + if ! $gl_gnulib_enabled_lchmod; then + gl_FUNC_LCHMOD + if test $HAVE_LCHMOD = 0; then + AC_LIBOBJ([lchmod]) + gl_PREREQ_LCHMOD + fi + gl_SYS_STAT_MODULE_INDICATOR([lchmod]) + gl_gnulib_enabled_lchmod=true fi } func_gl_gnulib_m4code_2049e887c7e5308faad27b3f894bb8c9 () @@ -647,6 +690,13 @@ AC_DEFUN([gl_INIT], gl_gnulib_enabled_strtoll=true fi } + func_gl_gnulib_m4code_utimens () + { + if ! $gl_gnulib_enabled_utimens; then + gl_UTIMENS + gl_gnulib_enabled_utimens=true + fi + } func_gl_gnulib_m4code_682e609604ccaac6be382e4ee3a4eaec () { if ! $gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec; then @@ -665,6 +715,15 @@ AC_DEFUN([gl_INIT], if test $HAVE_FACCESSAT = 0 || test $REPLACE_FACCESSAT = 1; then func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 fi + if test $HAVE_FCHMODAT = 0; then + func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b + fi + if test $HAVE_FCHMODAT = 0; then + func_gl_gnulib_m4code_lchmod + fi + if test $HAVE_FCHMODAT = 0; then + func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 + fi if test $HAVE_FCNTL = 0 || test $REPLACE_FCNTL = 1; then func_gl_gnulib_m4code_getdtablesize fi @@ -680,30 +739,42 @@ AC_DEFUN([gl_INIT], if test $HAVE_FSTATAT = 0 || test $REPLACE_FSTATAT = 1; then func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 fi + if test $HAVE_FUTIMENS = 0 || test $REPLACE_FUTIMENS = 1; then + func_gl_gnulib_m4code_utimens + fi + if case $host_os in mingw*) false;; *) test $HAVE_GETLOADAVG = 0;; esac; then + func_gl_gnulib_m4code_open + fi if test $REPLACE_GETOPT = 1; then func_gl_gnulib_m4code_be453cec5eecf5731a274f2de7f2db36 fi + if case $host_os in mingw*) false;; *) test $HAVE_GETRANDOM = 0 || test $REPLACE_GETRANDOM = 1;; esac; then + func_gl_gnulib_m4code_open + fi if test $NEED_LOCALTIME_BUFFER = 1; then func_gl_gnulib_m4code_2049e887c7e5308faad27b3f894bb8c9 fi - if test $REPLACE_MKTIME = 1; then - func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467 - fi if test $HAVE_READLINKAT = 0; then func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b fi if test $HAVE_READLINKAT = 0; then func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 fi - if test $ac_use_included_regex = yes; then - func_gl_gnulib_m4code_21ee726a3540c09237a8e70c0baf7467 - fi if { test $HAVE_DECL_STRTOIMAX = 0 || test $REPLACE_STRTOIMAX = 1; } && test $ac_cv_type_long_long_int = yes; then func_gl_gnulib_m4code_strtoll fi if test $HAVE_TIMEGM = 0 || test $REPLACE_TIMEGM = 1; then func_gl_gnulib_m4code_5264294aa0a5557541b53c8c741f7f31 fi + if test $HAVE_UTIMENSAT = 0 || test $REPLACE_UTIMENSAT = 1; then + func_gl_gnulib_m4code_260941c0e5dc67ec9e87d1fb321c300b + fi + if test $HAVE_UTIMENSAT = 0 || test $REPLACE_UTIMENSAT = 1; then + func_gl_gnulib_m4code_03e0aaad4cb89ca757653bd367a6ccb7 + fi + if test $HAVE_UTIMENSAT = 0 || test $REPLACE_UTIMENSAT = 1; then + func_gl_gnulib_m4code_utimens + fi m4_pattern_allow([^gl_GNULIB_ENABLED_]) AM_CONDITIONAL([gl_GNULIB_ENABLED_260941c0e5dc67ec9e87d1fb321c300b], [$gl_gnulib_enabled_260941c0e5dc67ec9e87d1fb321c300b]) AM_CONDITIONAL([gl_GNULIB_ENABLED_cloexec], [$gl_gnulib_enabled_cloexec]) @@ -713,7 +784,7 @@ AC_DEFUN([gl_INIT], AM_CONDITIONAL([gl_GNULIB_ENABLED_getgroups], [$gl_gnulib_enabled_getgroups]) AM_CONDITIONAL([gl_GNULIB_ENABLED_be453cec5eecf5731a274f2de7f2db36], [$gl_gnulib_enabled_be453cec5eecf5731a274f2de7f2db36]) AM_CONDITIONAL([gl_GNULIB_ENABLED_a9786850e999ae65a836a6041e8e5ed1], [$gl_gnulib_enabled_a9786850e999ae65a836a6041e8e5ed1]) - AM_CONDITIONAL([gl_GNULIB_ENABLED_21ee726a3540c09237a8e70c0baf7467], [$gl_gnulib_enabled_21ee726a3540c09237a8e70c0baf7467]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_lchmod], [$gl_gnulib_enabled_lchmod]) AM_CONDITIONAL([gl_GNULIB_ENABLED_2049e887c7e5308faad27b3f894bb8c9], [$gl_gnulib_enabled_2049e887c7e5308faad27b3f894bb8c9]) AM_CONDITIONAL([gl_GNULIB_ENABLED_malloca], [$gl_gnulib_enabled_malloca]) AM_CONDITIONAL([gl_GNULIB_ENABLED_5264294aa0a5557541b53c8c741f7f31], [$gl_gnulib_enabled_5264294aa0a5557541b53c8c741f7f31]) @@ -721,6 +792,7 @@ AC_DEFUN([gl_INIT], AM_CONDITIONAL([gl_GNULIB_ENABLED_03e0aaad4cb89ca757653bd367a6ccb7], [$gl_gnulib_enabled_03e0aaad4cb89ca757653bd367a6ccb7]) AM_CONDITIONAL([gl_GNULIB_ENABLED_6099e9737f757db36c47fa9d9f02e88c], [$gl_gnulib_enabled_6099e9737f757db36c47fa9d9f02e88c]) AM_CONDITIONAL([gl_GNULIB_ENABLED_strtoll], [$gl_gnulib_enabled_strtoll]) + AM_CONDITIONAL([gl_GNULIB_ENABLED_utimens], [$gl_gnulib_enabled_utimens]) AM_CONDITIONAL([gl_GNULIB_ENABLED_682e609604ccaac6be382e4ee3a4eaec], [$gl_gnulib_enabled_682e609604ccaac6be382e4ee3a4eaec]) # End of code from modules m4_ifval(gl_LIBSOURCES_LIST, [ @@ -876,6 +948,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/allocator.h lib/arg-nonnull.h lib/at-func.c + lib/attribute.h lib/binary-io.c lib/binary-io.h lib/byteswap.in.h @@ -903,7 +976,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/diffseq.h lib/dirent.in.h lib/dirfd.c - lib/dosname.h lib/dtoastr.c lib/dtotimespec.c lib/dup2.c @@ -913,11 +985,13 @@ AC_DEFUN([gl_FILE_LIST], [ lib/execinfo.in.h lib/explicit_bzero.c lib/faccessat.c + lib/fchmodat.c lib/fcntl.c lib/fcntl.in.h lib/fdopendir.c lib/filemode.c lib/filemode.h + lib/filename.h lib/filevercmp.c lib/filevercmp.h lib/flexmember.h @@ -929,6 +1003,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/fsync.c lib/ftoastr.c lib/ftoastr.h + lib/futimens.c lib/get-permissions.c lib/getdtablesize.c lib/getgroups.c @@ -942,6 +1017,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/getopt.in.h lib/getopt1.c lib/getopt_int.h + lib/getrandom.c lib/gettext.h lib/gettime.c lib/gettimeofday.c @@ -951,6 +1027,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/ignore-value.h lib/intprops.h lib/inttypes.in.h + lib/lchmod.c lib/libc-config.h lib/limits.in.h lib/localtime-buffer.c @@ -963,6 +1040,9 @@ AC_DEFUN([gl_FILE_LIST], [ lib/memmem.c lib/mempcpy.c lib/memrchr.c + lib/mini-gmp-gnulib.c + lib/mini-gmp.c + lib/mini-gmp.h lib/minmax.h lib/mkostemp.c lib/mktime-internal.h @@ -976,7 +1056,6 @@ AC_DEFUN([gl_FILE_LIST], [ lib/pipe2.c lib/pselect.c lib/pthread_sigmask.c - lib/putenv.c lib/qcopy-acl.c lib/readlink.c lib/readlinkat.c @@ -1014,6 +1093,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/strtol.c lib/strtoll.c lib/symlink.c + lib/sys_random.in.h lib/sys_select.in.h lib/sys_stat.in.h lib/sys_time.in.h @@ -1036,6 +1116,7 @@ AC_DEFUN([gl_FILE_LIST], [ lib/unlocked-io.h lib/utimens.c lib/utimens.h + lib/utimensat.c lib/verify.h lib/vla.h lib/warn-on-use.h @@ -1050,9 +1131,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/canonicalize.m4 m4/clock_time.m4 m4/copy-file-range.m4 - m4/count-leading-zeros.m4 - m4/count-one-bits.m4 - m4/count-trailing-zeros.m4 m4/d-type.m4 m4/dirent_h.m4 m4/dirfd.m4 @@ -1067,6 +1145,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/extensions.m4 m4/extern-inline.m4 m4/faccessat.m4 + m4/fchmodat.m4 m4/fcntl-o.m4 m4/fcntl.m4 m4/fcntl_h.m4 @@ -1078,10 +1157,12 @@ AC_DEFUN([gl_FILE_LIST], [ m4/fstatat.m4 m4/fsusage.m4 m4/fsync.m4 + m4/futimens.m4 m4/getdtablesize.m4 m4/getgroups.m4 m4/getloadavg.m4 m4/getopt.m4 + m4/getrandom.m4 m4/gettime.m4 m4/gettimeofday.m4 m4/gl-openssl.m4 @@ -1092,9 +1173,10 @@ AC_DEFUN([gl_FILE_LIST], [ m4/include_next.m4 m4/inttypes.m4 m4/largefile.m4 + m4/lchmod.m4 + m4/libgmp.m4 m4/limits-h.m4 m4/localtime-buffer.m4 - m4/longlong.m4 m4/lstat.m4 m4/malloca.m4 m4/manywarnings-c++.m4 @@ -1119,7 +1201,6 @@ AC_DEFUN([gl_FILE_LIST], [ m4/pipe2.m4 m4/pselect.m4 m4/pthread_sigmask.m4 - m4/putenv.m4 m4/readlink.m4 m4/readlinkat.m4 m4/regex.m4 @@ -1144,6 +1225,7 @@ AC_DEFUN([gl_FILE_LIST], [ m4/strtoimax.m4 m4/strtoll.m4 m4/symlink.m4 + m4/sys_random_h.m4 m4/sys_select_h.m4 m4/sys_socket_h.m4 m4/sys_stat_h.m4 @@ -1160,10 +1242,12 @@ AC_DEFUN([gl_FILE_LIST], [ m4/unistd_h.m4 m4/unlocked-io.m4 m4/utimens.m4 + m4/utimensat.m4 m4/utimes.m4 m4/vararrays.m4 m4/warn-on-use.m4 m4/warnings.m4 m4/wchar_t.m4 m4/wint_t.m4 + m4/zzgnulib.m4 ]) diff --git a/m4/group-member.m4 b/m4/group-member.m4 index 5b32b5ff498..ad7368ceecb 100644 --- a/m4/group-member.m4 +++ b/m4/group-member.m4 @@ -1,7 +1,6 @@ # serial 14 -# Copyright (C) 1999-2001, 2003-2007, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 1999-2001, 2003-2007, 2009-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/inttypes.m4 b/m4/inttypes.m4 index e037be6fcc5..224d0cdd8e2 100644 --- a/m4/inttypes.m4 +++ b/m4/inttypes.m4 @@ -1,4 +1,4 @@ -# inttypes.m4 serial 27 +# inttypes.m4 serial 29 dnl Copyright (C) 2006-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -28,6 +28,8 @@ AC_DEFUN_ONCE([gl_INTTYPES_INCOMPLETE], dnl corresponding gnulib module is not in use. gl_WARN_ON_USE_PREPARE([[#include <inttypes.h> ]], [imaxabs imaxdiv strtoimax strtoumax]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) # Ensure that the PRI* and SCN* macros are defined appropriately. @@ -113,10 +115,8 @@ AC_DEFUN([gl_INTTYPES_CHECK_LONG_LONG_INT_CONDITION], #if $2 #define CONDITION ($3) - #elif HAVE_LONG_LONG_INT - #define CONDITION ($4) #else - #define CONDITION 0 + #define CONDITION ($4) #endif int test[CONDITION ? 1 : -1];]])], [gl_cv_test_$1=yes], diff --git a/m4/largefile.m4 b/m4/largefile.m4 index f6863e46c49..8017ca70eb4 100644 --- a/m4/largefile.m4 +++ b/m4/largefile.m4 @@ -1,10 +1,27 @@ # Enable large files on systems where this is not the default. +# Enable support for files on Linux file systems with 64-bit inode numbers. # Copyright 1992-1996, 1998-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. +# The following macro works around a problem in Autoconf's AC_FUNC_FSEEKO: +# It does not set _LARGEFILE_SOURCE=1 on HP-UX/ia64 32-bit, although this +# setting of _LARGEFILE_SOURCE is needed so that <stdio.h> declares fseeko +# and ftello in C++ mode as well. +AC_DEFUN([gl_SET_LARGEFILE_SOURCE], +[ + AC_REQUIRE([AC_CANONICAL_HOST]) + AC_FUNC_FSEEKO + case "$host_os" in + hpux*) + AC_DEFINE([_LARGEFILE_SOURCE], [1], + [Define to 1 to make fseeko visible on some hosts (e.g. glibc 2.2).]) + ;; + esac +]) + # The following implementation works around a problem in autoconf <= 2.69; # AC_SYS_LARGEFILE does not configure for large inodes on Mac OS X 10.5, # or configures them incorrectly in some cases. @@ -57,6 +74,9 @@ rm -rf conftest*[]dnl # one must use special compiler options to get large-file access to work. # For more details about this brain damage please see: # http://www.unix.org/version2/whatsnew/lfs20mar.html +# Additionally, on Linux file systems with 64-bit inodes a file that happens +# to have a 64-bit inode number cannot be accessed by 32-bit applications on +# Linux x86/x86_64. This can occur with file systems such as XFS and NFS. AC_DEFUN([AC_SYS_LARGEFILE], [AC_ARG_ENABLE(largefile, [ --disable-largefile omit support for large files]) @@ -93,9 +113,6 @@ if test "$enable_largefile" != no; then [Define for large files, on AIX-style hosts.], [_AC_SYS_LARGEFILE_TEST_INCLUDES]) fi - - AC_DEFINE([_DARWIN_USE_64_BIT_INODE], [1], - [Enable large inode numbers on Mac OS X 10.5.]) fi ])# AC_SYS_LARGEFILE ])# m4_version_prereq 2.70 diff --git a/m4/lchmod.m4 b/m4/lchmod.m4 new file mode 100644 index 00000000000..a86a304f5f1 --- /dev/null +++ b/m4/lchmod.m4 @@ -0,0 +1,30 @@ +#serial 8 + +dnl Copyright (C) 2005-2006, 2008-2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl From Paul Eggert. +dnl Provide a replacement for lchmod on hosts that lack a working version. + +AC_DEFUN([gl_FUNC_LCHMOD], +[ + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + + dnl Persuade glibc <sys/stat.h> to declare lchmod(). + AC_REQUIRE([AC_USE_SYSTEM_EXTENSIONS]) + + AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles + + AC_CHECK_FUNCS_ONCE([lchmod lstat]) + if test "$ac_cv_func_lchmod" = no; then + HAVE_LCHMOD=0 + fi +]) + +# Prerequisites of lib/lchmod.c. +AC_DEFUN([gl_PREREQ_LCHMOD], +[ + : +]) diff --git a/m4/libgmp.m4 b/m4/libgmp.m4 new file mode 100644 index 00000000000..b569bb73462 --- /dev/null +++ b/m4/libgmp.m4 @@ -0,0 +1,44 @@ +# Configure the GMP library or a replacement. + +dnl Copyright 2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_LIBGMP], +[ + AC_ARG_WITH([libgmp], + [AS_HELP_STRING([--without-libgmp], + [do not use the GNU Multiple Precision (GMP) library; + this is the default on systems lacking libgmp.])]) + + AC_CHECK_HEADERS_ONCE([gmp.h]) + GMP_H=gmp.h + LIB_GMP= + + case $with_libgmp in + no) ;; + yes) GMP_H= LIB_GMP=-lgmp;; + *) if test "$ac_cv_header_gmp_h" = yes; then + gl_saved_LIBS=$LIBS + AC_SEARCH_LIBS([__gmpz_roinit_n], [gmp]) + LIBS=$gl_saved_LIBS + case $ac_cv_search___gmpz_roinit_n in + 'none needed') + GMP_H=;; + -*) + GMP_H= LIB_GMP=$ac_cv_search___gmpz_roinit_n;; + esac + fi;; + esac + + if test -z "$GMP_H"; then + AC_DEFINE([HAVE_GMP], 1, + [Define to 1 if you have the GMP library instead of just the + mini-gmp replacement.]) + fi + + AC_SUBST([LIB_GMP]) + AC_SUBST([GMP_H]) + AM_CONDITIONAL([GL_GENERATE_GMP_H], [test -n "$GMP_H"]) +]) diff --git a/m4/longlong.m4 b/m4/longlong.m4 deleted file mode 100644 index e878488ad54..00000000000 --- a/m4/longlong.m4 +++ /dev/null @@ -1,113 +0,0 @@ -# longlong.m4 serial 18 -dnl Copyright (C) 1999-2007, 2009-2020 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Paul Eggert. - -AC_PREREQ([2.62]) - -# Define HAVE_LONG_LONG_INT if 'long long int' works. -# This can be faster than what's in Autoconf 2.62 through 2.68. - -# Note: If the type 'long long int' exists but is only 32 bits large -# (as on some very old compilers), HAVE_LONG_LONG_INT will not be -# defined. In this case you can treat 'long long int' like 'long int'. - -AC_DEFUN([AC_TYPE_LONG_LONG_INT], -[ - AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) - AC_CACHE_CHECK([for long long int], [ac_cv_type_long_long_int], - [ac_cv_type_long_long_int=yes - if test "x${ac_cv_prog_cc_c99-no}" = xno; then - ac_cv_type_long_long_int=$ac_cv_type_unsigned_long_long_int - if test $ac_cv_type_long_long_int = yes; then - dnl Catch a bug in Tandem NonStop Kernel (OSS) cc -O circa 2004. - dnl If cross compiling, assume the bug is not important, since - dnl nobody cross compiles for this platform as far as we know. - AC_RUN_IFELSE( - [AC_LANG_PROGRAM( - [[@%:@include <limits.h> - @%:@ifndef LLONG_MAX - @%:@ define HALF \ - (1LL << (sizeof (long long int) * CHAR_BIT - 2)) - @%:@ define LLONG_MAX (HALF - 1 + HALF) - @%:@endif]], - [[long long int n = 1; - int i; - for (i = 0; ; i++) - { - long long int m = n << i; - if (m >> i != n) - return 1; - if (LLONG_MAX / 2 < m) - break; - } - return 0;]])], - [], - [ac_cv_type_long_long_int=no], - [:]) - fi - fi]) - if test $ac_cv_type_long_long_int = yes; then - AC_DEFINE([HAVE_LONG_LONG_INT], [1], - [Define to 1 if the system has the type 'long long int'.]) - fi -]) - -# Define HAVE_UNSIGNED_LONG_LONG_INT if 'unsigned long long int' works. -# This can be faster than what's in Autoconf 2.62 through 2.68. - -# Note: If the type 'unsigned long long int' exists but is only 32 bits -# large (as on some very old compilers), AC_TYPE_UNSIGNED_LONG_LONG_INT -# will not be defined. In this case you can treat 'unsigned long long int' -# like 'unsigned long int'. - -AC_DEFUN([AC_TYPE_UNSIGNED_LONG_LONG_INT], -[ - AC_CACHE_CHECK([for unsigned long long int], - [ac_cv_type_unsigned_long_long_int], - [ac_cv_type_unsigned_long_long_int=yes - if test "x${ac_cv_prog_cc_c99-no}" = xno; then - AC_LINK_IFELSE( - [_AC_TYPE_LONG_LONG_SNIPPET], - [], - [ac_cv_type_unsigned_long_long_int=no]) - fi]) - if test $ac_cv_type_unsigned_long_long_int = yes; then - AC_DEFINE([HAVE_UNSIGNED_LONG_LONG_INT], [1], - [Define to 1 if the system has the type 'unsigned long long int'.]) - fi -]) - -# Expands to a C program that can be used to test for simultaneous support -# of 'long long' and 'unsigned long long'. We don't want to say that -# 'long long' is available if 'unsigned long long' is not, or vice versa, -# because too many programs rely on the symmetry between signed and unsigned -# integer types (excluding 'bool'). -AC_DEFUN([_AC_TYPE_LONG_LONG_SNIPPET], -[ - AC_LANG_PROGRAM( - [[/* For now, do not test the preprocessor; as of 2007 there are too many - implementations with broken preprocessors. Perhaps this can - be revisited in 2012. In the meantime, code should not expect - #if to work with literals wider than 32 bits. */ - /* Test literals. */ - long long int ll = 9223372036854775807ll; - long long int nll = -9223372036854775807LL; - unsigned long long int ull = 18446744073709551615ULL; - /* Test constant expressions. */ - typedef int a[((-9223372036854775807LL < 0 && 0 < 9223372036854775807ll) - ? 1 : -1)]; - typedef int b[(18446744073709551615ULL <= (unsigned long long int) -1 - ? 1 : -1)]; - int i = 63;]], - [[/* Test availability of runtime routines for shift and division. */ - long long int llmax = 9223372036854775807ll; - unsigned long long int ullmax = 18446744073709551615ull; - return ((ll << 63) | (ll >> 63) | (ll < i) | (ll > i) - | (llmax / ll) | (llmax % ll) - | (ull << 63) | (ull >> 63) | (ull << i) | (ull >> i) - | (ullmax / ull) | (ullmax % ull));]]) -]) diff --git a/m4/malloca.m4 b/m4/malloca.m4 index 99e9dace2c5..930199da14a 100644 --- a/m4/malloca.m4 +++ b/m4/malloca.m4 @@ -1,6 +1,6 @@ -# malloca.m4 serial 1 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2020 Free Software -dnl Foundation, Inc. +# malloca.m4 serial 2 +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -11,5 +11,4 @@ AC_DEFUN([gl_MALLOCA], dnl @ALLOCA@ and @LTALLOCA@. dnl gl_FUNC_ALLOCA dnl Already brought in by the module dependencies. AC_REQUIRE([gl_EEMALLOC]) - AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) ]) diff --git a/m4/manywarnings.m4 b/m4/manywarnings.m4 index 783620da3ad..d18da048d9e 100644 --- a/m4/manywarnings.m4 +++ b/m4/manywarnings.m4 @@ -1,4 +1,4 @@ -# manywarnings.m4 serial 18 +# manywarnings.m4 serial 20 dnl Copyright (C) 2008-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -21,7 +21,7 @@ AC_DEFUN([gl_MANYWARN_COMPLEMENT], *" $gl_warn_item "*) ;; *) - gl_warn_set="$gl_warn_set $gl_warn_item" + gl_AS_VAR_APPEND([gl_warn_set], [" $gl_warn_item"]) ;; esac done @@ -49,12 +49,12 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)], AC_REQUIRE([AC_PROG_CC]) if test -n "$GCC"; then - dnl Check if -W -Werror -Wno-missing-field-initializers is supported + dnl Check if -Wextra -Werror -Wno-missing-field-initializers is supported dnl with the current $CC $CFLAGS $CPPFLAGS. AC_CACHE_CHECK([whether -Wno-missing-field-initializers is supported], [gl_cv_cc_nomfi_supported], [gl_save_CFLAGS="$CFLAGS" - CFLAGS="$CFLAGS -W -Werror -Wno-missing-field-initializers" + CFLAGS="$CFLAGS -Wextra -Werror -Wno-missing-field-initializers" AC_COMPILE_IFELSE( [AC_LANG_PROGRAM([[]], [[]])], [gl_cv_cc_nomfi_supported=yes], @@ -68,7 +68,7 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)], AC_CACHE_CHECK([whether -Wno-missing-field-initializers is needed], [gl_cv_cc_nomfi_needed], [gl_save_CFLAGS="$CFLAGS" - CFLAGS="$CFLAGS -W -Werror" + CFLAGS="$CFLAGS -Wextra -Werror" AC_COMPILE_IFELSE( [AC_LANG_PROGRAM( [[int f (void) @@ -105,133 +105,41 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)], # To compare this list to your installed GCC's, run this Bash command: # # comm -3 \ - # <((sed -n 's/^ *\(-[^ 0-9][^ ]*\) .*/\1/p' manywarnings.m4; \ + # <((sed -n 's/^ *\(-[^ 0-9][^ ]*\).*/\1/p' manywarnings.m4; \ # awk '/^[^#]/ {print $1}' ../build-aux/gcc-warning.spec) | sort) \ # <(LC_ALL=C gcc --help=warnings | sed -n 's/^ \(-[^ ]*\) .*/\1/p' | sort) - gl_manywarn_set= - for gl_manywarn_item in -fno-common \ - -W \ - -Wabsolute-value \ - -Waddress \ - -Waddress-of-packed-member \ - -Waggressive-loop-optimizations \ + $1= + for gl_manywarn_item in -fanalyzer -fno-common \ -Wall \ - -Wattribute-warning \ - -Wattributes \ + -Warith-conversion \ -Wbad-function-cast \ - -Wbool-compare \ - -Wbool-operation \ - -Wbuiltin-declaration-mismatch \ - -Wbuiltin-macro-redefined \ - -Wcannot-profile \ - -Wcast-align \ -Wcast-align=strict \ - -Wcast-function-type \ - -Wchar-subscripts \ - -Wclobbered \ - -Wcomment \ - -Wcomments \ - -Wcoverage-mismatch \ - -Wcpp \ - -Wdangling-else \ -Wdate-time \ - -Wdeprecated \ - -Wdeprecated-declarations \ - -Wdesignated-init \ -Wdisabled-optimization \ - -Wdiscarded-array-qualifiers \ - -Wdiscarded-qualifiers \ - -Wdiv-by-zero \ -Wdouble-promotion \ -Wduplicated-branches \ -Wduplicated-cond \ - -Wduplicate-decl-specifier \ - -Wempty-body \ - -Wendif-labels \ - -Wenum-compare \ - -Wexpansion-to-defined \ -Wextra \ - -Wformat-contains-nul \ - -Wformat-extra-args \ - -Wformat-nonliteral \ - -Wformat-security \ -Wformat-signedness \ - -Wformat-y2k \ - -Wformat-zero-length \ - -Wframe-address \ - -Wfree-nonheap-object \ - -Whsa \ - -Wif-not-aligned \ - -Wignored-attributes \ - -Wignored-qualifiers \ - -Wimplicit \ - -Wimplicit-function-declaration \ - -Wimplicit-int \ - -Wincompatible-pointer-types \ -Winit-self \ -Winline \ - -Wint-conversion \ - -Wint-in-bool-context \ - -Wint-to-pointer-cast \ - -Winvalid-memory-model \ -Winvalid-pch \ - -Wlogical-not-parentheses \ -Wlogical-op \ - -Wmain \ - -Wmaybe-uninitialized \ - -Wmemset-elt-size \ - -Wmemset-transposed-args \ - -Wmisleading-indentation \ - -Wmissing-attributes \ - -Wmissing-braces \ -Wmissing-declarations \ - -Wmissing-field-initializers \ -Wmissing-include-dirs \ - -Wmissing-parameter-type \ - -Wmissing-profile \ -Wmissing-prototypes \ - -Wmultichar \ - -Wmultistatement-macros \ - -Wnarrowing \ -Wnested-externs \ - -Wnonnull \ - -Wnonnull-compare \ -Wnull-dereference \ - -Wodr \ - -Wold-style-declaration \ -Wold-style-definition \ -Wopenmp-simd \ - -Woverflow \ -Woverlength-strings \ - -Woverride-init \ -Wpacked \ - -Wpacked-bitfield-compat \ - -Wpacked-not-aligned \ - -Wparentheses \ -Wpointer-arith \ - -Wpointer-compare \ - -Wpointer-sign \ - -Wpointer-to-int-cast \ - -Wpragmas \ - -Wpsabi \ - -Wrestrict \ - -Wreturn-local-addr \ - -Wreturn-type \ - -Wscalar-storage-order \ - -Wsequence-point \ -Wshadow \ - -Wshift-count-negative \ - -Wshift-count-overflow \ - -Wshift-negative-value \ - -Wsizeof-array-argument \ - -Wsizeof-pointer-div \ - -Wsizeof-pointer-memaccess \ -Wstack-protector \ - -Wstrict-aliasing \ -Wstrict-overflow \ -Wstrict-prototypes \ - -Wstringop-truncation \ -Wsuggest-attribute=cold \ -Wsuggest-attribute=const \ -Wsuggest-attribute=format \ @@ -240,93 +148,63 @@ m4_defun([gl_MANYWARN_ALL_GCC(C)], -Wsuggest-attribute=pure \ -Wsuggest-final-methods \ -Wsuggest-final-types \ - -Wswitch \ - -Wswitch-bool \ - -Wswitch-unreachable \ -Wsync-nand \ -Wsystem-headers \ - -Wtautological-compare \ -Wtrampolines \ - -Wtrigraphs \ - -Wtype-limits \ -Wuninitialized \ -Wunknown-pragmas \ -Wunsafe-loop-optimizations \ - -Wunused \ - -Wunused-but-set-parameter \ - -Wunused-but-set-variable \ - -Wunused-function \ - -Wunused-label \ - -Wunused-local-typedefs \ -Wunused-macros \ - -Wunused-parameter \ - -Wunused-result \ - -Wunused-value \ - -Wunused-variable \ - -Wvarargs \ -Wvariadic-macros \ -Wvector-operation-performance \ -Wvla \ - -Wvolatile-register-var \ -Wwrite-strings \ \ ; do - gl_manywarn_set="$gl_manywarn_set $gl_manywarn_item" + gl_AS_VAR_APPEND([$1], [" $gl_manywarn_item"]) done # gcc --help=warnings outputs an unusual form for these options; list # them here so that the above 'comm' command doesn't report a false match. - # Would prefer "min (PTRDIFF_MAX, SIZE_MAX)", but it must be a literal. - # Also, AC_COMPUTE_INT requires it to fit in a long; it is 2**63 on - # the only platforms where it does not fit in a long, so make that - # a special case. - AC_MSG_CHECKING([max safe object size]) - AC_COMPUTE_INT([gl_alloc_max], - [LONG_MAX < (PTRDIFF_MAX < (size_t) -1 ? PTRDIFF_MAX : (size_t) -1) - ? -1 - : PTRDIFF_MAX < (size_t) -1 ? (long) PTRDIFF_MAX : (long) (size_t) -1], - [[#include <limits.h> - #include <stddef.h> - #include <stdint.h> - ]], - [gl_alloc_max=2147483647]) - case $gl_alloc_max in - -1) gl_alloc_max=9223372036854775807;; - esac - AC_MSG_RESULT([$gl_alloc_max]) - gl_manywarn_set="$gl_manywarn_set -Walloc-size-larger-than=$gl_alloc_max" - gl_manywarn_set="$gl_manywarn_set -Warray-bounds=2" - gl_manywarn_set="$gl_manywarn_set -Wattribute-alias=2" - gl_manywarn_set="$gl_manywarn_set -Wformat-overflow=2" - gl_manywarn_set="$gl_manywarn_set -Wformat-truncation=2" - gl_manywarn_set="$gl_manywarn_set -Wimplicit-fallthrough=5" - gl_manywarn_set="$gl_manywarn_set -Wnormalized=nfc" - gl_manywarn_set="$gl_manywarn_set -Wshift-overflow=2" - gl_manywarn_set="$gl_manywarn_set -Wstringop-overflow=2" - gl_manywarn_set="$gl_manywarn_set -Wunused-const-variable=2" - gl_manywarn_set="$gl_manywarn_set -Wvla-larger-than=4031" + gl_AS_VAR_APPEND([$1], [' -Warray-bounds=2']) + gl_AS_VAR_APPEND([$1], [' -Wattribute-alias=2']) + gl_AS_VAR_APPEND([$1], [' -Wformat-overflow=2']) + gl_AS_VAR_APPEND([$1], [' -Wformat=2']) + gl_AS_VAR_APPEND([$1], [' -Wformat-truncation=2']) + gl_AS_VAR_APPEND([$1], [' -Wimplicit-fallthrough=5']) + gl_AS_VAR_APPEND([$1], [' -Wshift-overflow=2']) + gl_AS_VAR_APPEND([$1], [' -Wunused-const-variable=2']) + gl_AS_VAR_APPEND([$1], [' -Wvla-larger-than=4031']) # These are needed for older GCC versions. if test -n "$GCC"; then case `($CC --version) 2>/dev/null` in 'gcc (GCC) '[[0-3]].* | \ 'gcc (GCC) '4.[[0-7]].*) - gl_manywarn_set="$gl_manywarn_set -fdiagnostics-show-option" - gl_manywarn_set="$gl_manywarn_set -funit-at-a-time" + gl_AS_VAR_APPEND([$1], [' -fdiagnostics-show-option']) + gl_AS_VAR_APPEND([$1], [' -funit-at-a-time']) ;; esac fi # Disable specific options as needed. if test "$gl_cv_cc_nomfi_needed" = yes; then - gl_manywarn_set="$gl_manywarn_set -Wno-missing-field-initializers" + gl_AS_VAR_APPEND([$1], [' -Wno-missing-field-initializers']) fi if test "$gl_cv_cc_uninitialized_supported" = no; then - gl_manywarn_set="$gl_manywarn_set -Wno-uninitialized" + gl_AS_VAR_APPEND([$1], [' -Wno-uninitialized']) fi - $1=$gl_manywarn_set + # Some warnings have too many false alarms in GCC 10.1. + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=93695 + gl_AS_VAR_APPEND([$1], [' -Wno-analyzer-double-free']) + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94458 + gl_AS_VAR_APPEND([$1], [' -Wno-analyzer-malloc-leak']) + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=94851 + gl_AS_VAR_APPEND([$1], [' -Wno-analyzer-null-dereference']) + # https://gcc.gnu.org/bugzilla/show_bug.cgi?id=95758 + gl_AS_VAR_APPEND([$1], [' -Wno-analyzer-use-after-free']) AC_LANG_POP([C]) ]) diff --git a/m4/memmem.m4 b/m4/memmem.m4 index e034d7bd775..35a5bb19d1a 100644 --- a/m4/memmem.m4 +++ b/m4/memmem.m4 @@ -1,4 +1,4 @@ -# memmem.m4 serial 26 +# memmem.m4 serial 27 dnl Copyright (C) 2002-2004, 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -37,7 +37,7 @@ AC_DEFUN([gl_FUNC_MEMMEM_SIMPLE], /* Check for empty needle behavior. */ { const char *haystack = "AAA"; - if (memmem (haystack, 3, NULL, 0) != haystack) + if (memmem (haystack, 3, (const char *) 1, 0) != haystack) result |= 2; } return result; diff --git a/m4/mempcpy.m4 b/m4/mempcpy.m4 index 63e4087784b..899f12a880a 100644 --- a/m4/mempcpy.m4 +++ b/m4/mempcpy.m4 @@ -1,6 +1,6 @@ # mempcpy.m4 serial 11 -dnl Copyright (C) 2003-2004, 2006-2007, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2003-2004, 2006-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/memrchr.m4 b/m4/memrchr.m4 index 8e33fb96a07..95990ed6b76 100644 --- a/m4/memrchr.m4 +++ b/m4/memrchr.m4 @@ -1,6 +1,6 @@ # memrchr.m4 serial 10 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/mktime.m4 b/m4/mktime.m4 index 5e89f20e979..c00843f0f40 100644 --- a/m4/mktime.m4 +++ b/m4/mktime.m4 @@ -1,6 +1,6 @@ # serial 31 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/nstrftime.m4 b/m4/nstrftime.m4 index ec41d42f4ba..6f2762aa276 100644 --- a/m4/nstrftime.m4 +++ b/m4/nstrftime.m4 @@ -1,7 +1,6 @@ -# serial 34 +# serial 35 -# Copyright (C) 1996-1997, 1999-2007, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 1996-1997, 1999-2007, 2009-2020 Free Software Foundation, Inc. # # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -11,6 +10,8 @@ AC_DEFUN([gl_FUNC_GNU_STRFTIME], [ + AC_REQUIRE([AC_C_RESTRICT]) + # This defines (or not) HAVE_TZNAME and HAVE_TM_ZONE. AC_REQUIRE([AC_STRUCT_TIMEZONE]) diff --git a/m4/pathmax.m4 b/m4/pathmax.m4 index dc6bc3bceba..bb4fdeba750 100644 --- a/m4/pathmax.m4 +++ b/m4/pathmax.m4 @@ -1,6 +1,6 @@ # pathmax.m4 serial 11 -dnl Copyright (C) 2002-2003, 2005-2006, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2006, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/putenv.m4 b/m4/putenv.m4 deleted file mode 100644 index e38f8c56940..00000000000 --- a/m4/putenv.m4 +++ /dev/null @@ -1,60 +0,0 @@ -# putenv.m4 serial 24 -dnl Copyright (C) 2002-2020 Free Software Foundation, Inc. -dnl This file is free software; the Free Software Foundation -dnl gives unlimited permission to copy and/or distribute it, -dnl with or without modifications, as long as this notice is preserved. - -dnl From Jim Meyering. -dnl -dnl Check whether putenv ("FOO") removes FOO from the environment. -dnl The putenv in libc on at least SunOS 4.1.4 does *not* do that. - -AC_DEFUN([gl_FUNC_PUTENV], -[ - AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) - AC_REQUIRE([AC_CANONICAL_HOST]) dnl for cross-compiles - AC_CACHE_CHECK([for putenv compatible with GNU and SVID], - [gl_cv_func_svid_putenv], - [AC_RUN_IFELSE([AC_LANG_PROGRAM([AC_INCLUDES_DEFAULT],[[ - /* Put it in env. */ - if (putenv ("CONFTEST_putenv=val")) - return 1; - - /* Try to remove it. */ - if (putenv ("CONFTEST_putenv")) - return 2; - - /* Make sure it was deleted. */ - if (getenv ("CONFTEST_putenv") != 0) - return 3; - - return 0; - ]])], - gl_cv_func_svid_putenv=yes, - gl_cv_func_svid_putenv=no, - dnl When crosscompiling, assume putenv is broken. - [case "$host_os" in - # Guess yes on glibc systems. - *-gnu* | gnu*) gl_cv_func_svid_putenv="guessing yes" ;; - # Guess yes on musl systems. - *-musl*) gl_cv_func_svid_putenv="guessing yes" ;; - # Guess no on native Windows. - mingw*) gl_cv_func_svid_putenv="guessing no" ;; - # If we don't know, obey --enable-cross-guesses. - *) gl_cv_func_svid_putenv="$gl_cross_guess_normal" ;; - esac - ]) - ]) - case "$gl_cv_func_svid_putenv" in - *yes) ;; - *) - REPLACE_PUTENV=1 - ;; - esac -]) - -# Prerequisites of lib/putenv.c. -AC_DEFUN([gl_PREREQ_PUTENV], -[ - AC_CHECK_DECLS([_putenv]) -]) diff --git a/m4/regex.m4 b/m4/regex.m4 index 65f518582c1..e723f591216 100644 --- a/m4/regex.m4 +++ b/m4/regex.m4 @@ -1,4 +1,4 @@ -# serial 69 +# serial 70 # Copyright (C) 1996-2001, 2003-2020 Free Software Foundation, Inc. # @@ -90,11 +90,14 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern (pat, sizeof pat - 1, ®ex); if (s) result |= 1; - else if (re_search (®ex, data, sizeof data - 1, - 0, sizeof data - 1, ®s) - != -1) - result |= 1; - regfree (®ex); + else + { + if (re_search (®ex, data, sizeof data - 1, + 0, sizeof data - 1, ®s) + != -1) + result |= 1; + regfree (®ex); + } } { @@ -125,8 +128,8 @@ AC_DEFUN([gl_REGEX], 0, sizeof data - 1, 0); if (i != 0 && i != 21) result |= 1; + regfree (®ex); } - regfree (®ex); } if (! setlocale (LC_ALL, "C")) @@ -139,9 +142,13 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern ("a[^x]b", 6, ®ex); if (s) result |= 2; - /* This should fail, but succeeds for glibc-2.5. */ - else if (re_search (®ex, "a\nb", 3, 0, 3, ®s) != -1) - result |= 2; + else + { + /* This should fail, but succeeds for glibc-2.5. */ + if (re_search (®ex, "a\nb", 3, 0, 3, ®s) != -1) + result |= 2; + regfree (®ex); + } /* This regular expression is from Spencer ere test number 75 in grep-2.3. */ @@ -153,7 +160,10 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern ("a[[:@:>@:]]b\n", 11, ®ex); /* This should fail with _Invalid character class name_ error. */ if (!s) - result |= 4; + { + result |= 4; + regfree (®ex); + } /* Ensure that [b-a] is diagnosed as invalid, when using RE_NO_EMPTY_RANGES. */ @@ -161,13 +171,18 @@ AC_DEFUN([gl_REGEX], memset (®ex, 0, sizeof regex); s = re_compile_pattern ("a[b-a]", 6, ®ex); if (s == 0) - result |= 8; + { + result |= 8; + regfree (®ex); + } /* This should succeed, but does not for glibc-2.1.3. */ memset (®ex, 0, sizeof regex); s = re_compile_pattern ("{1", 2, ®ex); if (s) result |= 8; + else + regfree (®ex); /* The following example is derived from a problem report against gawk from Jorge Stolfi <stolfi@ic.unicamp.br>. */ @@ -175,17 +190,35 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern ("[an\371]*n", 7, ®ex); if (s) result |= 8; - /* This should match, but does not for glibc-2.2.1. */ - else if (re_match (®ex, "an", 2, 0, ®s) != 2) - result |= 8; + else + { + /* This should match, but does not for glibc-2.2.1. */ + if (re_match (®ex, "an", 2, 0, ®s) != 2) + result |= 8; + else + { + free (regs.start); + free (regs.end); + } + regfree (®ex); + } memset (®ex, 0, sizeof regex); s = re_compile_pattern ("x", 1, ®ex); if (s) result |= 8; - /* glibc-2.2.93 does not work with a negative RANGE argument. */ - else if (re_search (®ex, "wxy", 3, 2, -2, ®s) != 1) - result |= 8; + else + { + /* glibc-2.2.93 does not work with a negative RANGE argument. */ + if (re_search (®ex, "wxy", 3, 2, -2, ®s) != 1) + result |= 8; + else + { + free (regs.start); + free (regs.end); + } + regfree (®ex); + } /* The version of regex.c in older versions of gnulib ignored RE_ICASE. Detect that problem too. */ @@ -194,8 +227,17 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern ("x", 1, ®ex); if (s) result |= 16; - else if (re_search (®ex, "WXY", 3, 0, 3, ®s) < 0) - result |= 16; + else + { + if (re_search (®ex, "WXY", 3, 0, 3, ®s) < 0) + result |= 16; + else + { + free (regs.start); + free (regs.end); + } + regfree (®ex); + } /* Catch a bug reported by Vin Shelton in https://lists.gnu.org/r/bug-coreutils/2007-06/msg00089.html @@ -207,6 +249,8 @@ AC_DEFUN([gl_REGEX], s = re_compile_pattern ("[[:alnum:]_-]\\\\+$", 16, ®ex); if (s) result |= 32; + else + regfree (®ex); /* REG_STARTEND was added to glibc on 2004-01-15. Reject older versions. */ @@ -221,8 +265,14 @@ AC_DEFUN([gl_REGEX], re_set_syntax (RE_SYNTAX_POSIX_EGREP); memset (®ex, 0, sizeof regex); s = re_compile_pattern ("0|()0|\\1|0", 10, ®ex); - if (!s || strcmp (s, "Invalid back reference")) + if (!s) result |= 64; + else + { + if (strcmp (s, "Invalid back reference")) + result |= 64; + regfree (®ex); + } #if 0 /* It would be nice to reject hosts whose regoff_t values are too diff --git a/m4/sig2str.m4 b/m4/sig2str.m4 index c9b1a860a17..415290c4dee 100644 --- a/m4/sig2str.m4 +++ b/m4/sig2str.m4 @@ -1,6 +1,5 @@ # serial 7 -dnl Copyright (C) 2002, 2005-2006, 2009-2020 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2002, 2005-2006, 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/signal_h.m4 b/m4/signal_h.m4 index 08684384314..b2629809f18 100644 --- a/m4/signal_h.m4 +++ b/m4/signal_h.m4 @@ -1,4 +1,4 @@ -# signal_h.m4 serial 18 +# signal_h.m4 serial 19 dnl Copyright (C) 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -34,6 +34,8 @@ AC_DEFUN([gl_SIGNAL_H], ]], [pthread_sigmask sigaction sigaddset sigdelset sigemptyset sigfillset sigismember sigpending sigprocmask]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_CHECK_TYPE_SIGSET_T], diff --git a/m4/ssize_t.m4 b/m4/ssize_t.m4 index b77032b47a3..6c0a588873c 100644 --- a/m4/ssize_t.m4 +++ b/m4/ssize_t.m4 @@ -1,6 +1,5 @@ # ssize_t.m4 serial 5 (gettext-0.18.2) -dnl Copyright (C) 2001-2003, 2006, 2010-2020 Free Software Foundation, -dnl Inc. +dnl Copyright (C) 2001-2003, 2006, 2010-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/st_dm_mode.m4 b/m4/st_dm_mode.m4 index 9c44ae73dc1..5dad161c3b2 100644 --- a/m4/st_dm_mode.m4 +++ b/m4/st_dm_mode.m4 @@ -1,7 +1,6 @@ # serial 6 -# Copyright (C) 1998-1999, 2001, 2009-2020 Free Software Foundation, -# Inc. +# Copyright (C) 1998-1999, 2001, 2009-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. diff --git a/m4/stat-time.m4 b/m4/stat-time.m4 index 59bd29f91ac..0ac3f7272e3 100644 --- a/m4/stat-time.m4 +++ b/m4/stat-time.m4 @@ -1,7 +1,7 @@ # Checks for stat-related time functions. -# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2020 Free -# Software Foundation, Inc. +# Copyright (C) 1998-1999, 2001, 2003, 2005-2007, 2009-2020 Free Software +# Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/stdint.m4 b/m4/stdint.m4 index 3f75a18f32c..29ad826d8ea 100644 --- a/m4/stdint.m4 +++ b/m4/stdint.m4 @@ -1,4 +1,4 @@ -# stdint.m4 serial 53 +# stdint.m4 serial 54 dnl Copyright (C) 2001-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -17,21 +17,12 @@ AC_DEFUN_ONCE([gl_STDINT_H], AC_REQUIRE([gl_LIMITS_H]) AC_REQUIRE([gt_TYPE_WINT_T]) - dnl Check for long long int and unsigned long long int. - AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) - if test $ac_cv_type_long_long_int = yes; then - HAVE_LONG_LONG_INT=1 - else - HAVE_LONG_LONG_INT=0 - fi - AC_SUBST([HAVE_LONG_LONG_INT]) - AC_REQUIRE([AC_TYPE_UNSIGNED_LONG_LONG_INT]) - if test $ac_cv_type_unsigned_long_long_int = yes; then - HAVE_UNSIGNED_LONG_LONG_INT=1 - else - HAVE_UNSIGNED_LONG_LONG_INT=0 - fi - AC_SUBST([HAVE_UNSIGNED_LONG_LONG_INT]) + dnl For backward compatibility. Some packages may still be testing these + dnl macros. + AC_DEFINE([HAVE_LONG_LONG_INT], [1], + [Define to 1 if the system has the type 'long long int'.]) + AC_DEFINE([HAVE_UNSIGNED_LONG_LONG_INT], [1], + [Define to 1 if the system has the type 'unsigned long long int'.]) dnl Check for <wchar.h>, in the same way as gl_WCHAR_H does. AC_CHECK_HEADERS_ONCE([wchar.h]) diff --git a/m4/stdio_h.m4 b/m4/stdio_h.m4 index c603b514d96..5f968bc26a5 100644 --- a/m4/stdio_h.m4 +++ b/m4/stdio_h.m4 @@ -1,4 +1,4 @@ -# stdio_h.m4 serial 49 +# stdio_h.m4 serial 50 dnl Copyright (C) 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -107,6 +107,8 @@ AC_DEFUN([gl_STDIO_H], gl_WARN_ON_USE_PREPARE([[#include <stdio.h> ]], [dprintf fpurge fseeko ftello getdelim getline gets pclose popen renameat snprintf tmpfile vdprintf vsnprintf]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_STDIO_MODULE_INDICATOR], diff --git a/m4/stdlib_h.m4 b/m4/stdlib_h.m4 index 61a3e31edac..743066a6336 100644 --- a/m4/stdlib_h.m4 +++ b/m4/stdlib_h.m4 @@ -1,4 +1,4 @@ -# stdlib_h.m4 serial 48 +# stdlib_h.m4 serial 49 dnl Copyright (C) 2007-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -27,6 +27,8 @@ AC_DEFUN([gl_STDLIB_H], posix_openpt ptsname ptsname_r qsort_r random random_r reallocarray realpath rpmatch secure_getenv setenv setstate setstate_r srandom srandom_r strtod strtold strtoll strtoull unlockpt unsetenv]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_STDLIB_MODULE_INDICATOR], diff --git a/m4/string_h.m4 b/m4/string_h.m4 index 4c1f685eabd..516b346b311 100644 --- a/m4/string_h.m4 +++ b/m4/string_h.m4 @@ -5,7 +5,7 @@ # gives unlimited permission to copy and/or distribute it, # with or without modifications, as long as this notice is preserved. -# serial 22 +# serial 24 # Written by Paul Eggert. @@ -18,7 +18,6 @@ AC_DEFUN([gl_HEADER_STRING_H], AC_DEFUN([gl_HEADER_STRING_H_BODY], [ - AC_REQUIRE([AC_C_RESTRICT]) AC_REQUIRE([gl_HEADER_STRING_H_DEFAULTS]) gl_NEXT_HEADERS([string.h]) @@ -30,6 +29,8 @@ AC_DEFUN([gl_HEADER_STRING_H_BODY], [ffsl ffsll memmem mempcpy memrchr rawmemchr stpcpy stpncpy strchrnul strdup strncat strndup strnlen strpbrk strsep strcasestr strtok_r strerror_r strsignal strverscmp]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_STRING_MODULE_INDICATOR], @@ -86,7 +87,6 @@ AC_DEFUN([gl_HEADER_STRING_H_DEFAULTS], HAVE_EXPLICIT_BZERO=1; AC_SUBST([HAVE_EXPLICIT_BZERO]) HAVE_FFSL=1; AC_SUBST([HAVE_FFSL]) HAVE_FFSLL=1; AC_SUBST([HAVE_FFSLL]) - HAVE_MEMCHR=1; AC_SUBST([HAVE_MEMCHR]) HAVE_DECL_MEMMEM=1; AC_SUBST([HAVE_DECL_MEMMEM]) HAVE_MEMPCPY=1; AC_SUBST([HAVE_MEMPCPY]) HAVE_DECL_MEMRCHR=1; AC_SUBST([HAVE_DECL_MEMRCHR]) diff --git a/m4/strnlen.m4 b/m4/strnlen.m4 index 67d4eb05c03..71b8e1baffe 100644 --- a/m4/strnlen.m4 +++ b/m4/strnlen.m4 @@ -1,6 +1,6 @@ # strnlen.m4 serial 13 -dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software -dnl Foundation, Inc. +dnl Copyright (C) 2002-2003, 2005-2007, 2009-2020 Free Software Foundation, +dnl Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. diff --git a/m4/strtoimax.m4 b/m4/strtoimax.m4 index de97d75ce67..4958e3dcd50 100644 --- a/m4/strtoimax.m4 +++ b/m4/strtoimax.m4 @@ -1,6 +1,5 @@ -# strtoimax.m4 serial 15 -dnl Copyright (C) 2002-2004, 2006, 2009-2020 Free Software Foundation, -dnl Inc. +# strtoimax.m4 serial 16 +dnl Copyright (C) 2002-2004, 2006, 2009-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -86,5 +85,4 @@ int main () # Prerequisites of lib/strtoimax.c. AC_DEFUN([gl_PREREQ_STRTOIMAX], [ AC_CHECK_DECLS([strtoll]) - AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) ]) diff --git a/m4/strtoll.m4 b/m4/strtoll.m4 index af962836ec6..edcde3b5582 100644 --- a/m4/strtoll.m4 +++ b/m4/strtoll.m4 @@ -1,6 +1,5 @@ -# strtoll.m4 serial 7 -dnl Copyright (C) 2002, 2004, 2006, 2008-2020 Free Software Foundation, -dnl Inc. +# strtoll.m4 serial 8 +dnl Copyright (C) 2002, 2004, 2006, 2008-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, dnl with or without modifications, as long as this notice is preserved. @@ -8,14 +7,9 @@ dnl with or without modifications, as long as this notice is preserved. AC_DEFUN([gl_FUNC_STRTOLL], [ AC_REQUIRE([gl_STDLIB_H_DEFAULTS]) - dnl We don't need (and can't compile) the replacement strtoll - dnl unless the type 'long long int' exists. - AC_REQUIRE([AC_TYPE_LONG_LONG_INT]) - if test "$ac_cv_type_long_long_int" = yes; then - AC_CHECK_FUNCS([strtoll]) - if test $ac_cv_func_strtoll = no; then - HAVE_STRTOLL=0 - fi + AC_CHECK_FUNCS([strtoll]) + if test $ac_cv_func_strtoll = no; then + HAVE_STRTOLL=0 fi ]) diff --git a/m4/sys_random_h.m4 b/m4/sys_random_h.m4 new file mode 100644 index 00000000000..a964b157841 --- /dev/null +++ b/m4/sys_random_h.m4 @@ -0,0 +1,52 @@ +# sys_random_h.m4 serial 4 +dnl Copyright (C) 2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +AC_DEFUN([gl_HEADER_SYS_RANDOM], +[ + AC_REQUIRE([gl_SYS_RANDOM_H_DEFAULTS]) + dnl <sys/random.h> is always overridden, because of GNULIB_POSIXCHECK. + gl_CHECK_NEXT_HEADERS([sys/random.h]) + if test $ac_cv_header_sys_random_h = yes; then + HAVE_SYS_RANDOM_H=1 + else + HAVE_SYS_RANDOM_H=0 + fi + AC_SUBST([HAVE_SYS_RANDOM_H]) + + m4_ifdef([gl_UNISTD_H_DEFAULTS], [AC_REQUIRE([gl_UNISTD_H_DEFAULTS])]) + if test $ac_cv_header_sys_random_h = yes; then + UNISTD_H_HAVE_SYS_RANDOM_H=1 + fi + + dnl Check for declarations of anything we want to poison if the + dnl corresponding gnulib module is not in use. + gl_WARN_ON_USE_PREPARE([[ +#if HAVE_SYS_RANDOM_H +/* Additional includes are needed before <sys/random.h> on Mac OS X. */ +# include <sys/types.h> +# include <stdlib.h> +# include <sys/random.h> +#endif + ]], + [getrandom]) +]) + +AC_DEFUN([gl_SYS_RANDOM_MODULE_INDICATOR], +[ + dnl Use AC_REQUIRE here, so that the default settings are expanded once only. + AC_REQUIRE([gl_SYS_RANDOM_H_DEFAULTS]) + gl_MODULE_INDICATOR_SET_VARIABLE([$1]) + dnl Define it also as a C macro, for the benefit of the unit tests. + gl_MODULE_INDICATOR_FOR_TESTS([$1]) +]) + +AC_DEFUN([gl_SYS_RANDOM_H_DEFAULTS], +[ + GNULIB_GETRANDOM=0; AC_SUBST([GNULIB_GETRANDOM]) + dnl Assume proper GNU behavior unless another module says otherwise. + HAVE_GETRANDOM=1; AC_SUBST([HAVE_GETRANDOM]) + REPLACE_GETRANDOM=0; AC_SUBST([REPLACE_GETRANDOM]) +]) diff --git a/m4/sys_socket_h.m4 b/m4/sys_socket_h.m4 index 1471aeaec41..bf902f08108 100644 --- a/m4/sys_socket_h.m4 +++ b/m4/sys_socket_h.m4 @@ -1,4 +1,4 @@ -# sys_socket_h.m4 serial 24 +# sys_socket_h.m4 serial 25 dnl Copyright (C) 2005-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -95,6 +95,8 @@ AC_DEFUN([gl_HEADER_SYS_SOCKET], #include <sys/socket.h> ]], [socket connect accept bind getpeername getsockname getsockopt listen recv send recvfrom sendto setsockopt shutdown accept4]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_PREREQ_SYS_H_SOCKET], diff --git a/m4/sys_stat_h.m4 b/m4/sys_stat_h.m4 index d63df9ebffd..929144d155b 100644 --- a/m4/sys_stat_h.m4 +++ b/m4/sys_stat_h.m4 @@ -1,4 +1,4 @@ -# sys_stat_h.m4 serial 31 -*- Autoconf -*- +# sys_stat_h.m4 serial 34 -*- Autoconf -*- dnl Copyright (C) 2006-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -46,9 +46,11 @@ AC_DEFUN([gl_HEADER_SYS_STAT_H], dnl Check for declarations of anything we want to poison if the dnl corresponding gnulib module is not in use. gl_WARN_ON_USE_PREPARE([[#include <sys/stat.h> - ]], [fchmodat fstat fstatat futimens lchmod lstat mkdirat mkfifo mkfifoat - mknod mknodat stat utimensat]) -]) # gl_HEADER_SYS_STAT_H + ]], [fchmodat fstat fstatat futimens getumask lchmod lstat + mkdirat mkfifo mkfifoat mknod mknodat stat utimensat]) + + AC_REQUIRE([AC_C_RESTRICT]) +]) AC_DEFUN([gl_SYS_STAT_MODULE_INDICATOR], [ @@ -66,6 +68,7 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS], GNULIB_FSTAT=0; AC_SUBST([GNULIB_FSTAT]) GNULIB_FSTATAT=0; AC_SUBST([GNULIB_FSTATAT]) GNULIB_FUTIMENS=0; AC_SUBST([GNULIB_FUTIMENS]) + GNULIB_GETUMASK=0; AC_SUBST([GNULIB_GETUMASK]) GNULIB_LCHMOD=0; AC_SUBST([GNULIB_LCHMOD]) GNULIB_LSTAT=0; AC_SUBST([GNULIB_LSTAT]) GNULIB_MKDIRAT=0; AC_SUBST([GNULIB_MKDIRAT]) @@ -80,6 +83,7 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS], HAVE_FCHMODAT=1; AC_SUBST([HAVE_FCHMODAT]) HAVE_FSTATAT=1; AC_SUBST([HAVE_FSTATAT]) HAVE_FUTIMENS=1; AC_SUBST([HAVE_FUTIMENS]) + HAVE_GETUMASK=1; AC_SUBST([HAVE_GETUMASK]) HAVE_LCHMOD=1; AC_SUBST([HAVE_LCHMOD]) HAVE_LSTAT=1; AC_SUBST([HAVE_LSTAT]) HAVE_MKDIRAT=1; AC_SUBST([HAVE_MKDIRAT]) @@ -88,6 +92,7 @@ AC_DEFUN([gl_SYS_STAT_H_DEFAULTS], HAVE_MKNOD=1; AC_SUBST([HAVE_MKNOD]) HAVE_MKNODAT=1; AC_SUBST([HAVE_MKNODAT]) HAVE_UTIMENSAT=1; AC_SUBST([HAVE_UTIMENSAT]) + REPLACE_FCHMODAT=0; AC_SUBST([REPLACE_FCHMODAT]) REPLACE_FSTAT=0; AC_SUBST([REPLACE_FSTAT]) REPLACE_FSTATAT=0; AC_SUBST([REPLACE_FSTATAT]) REPLACE_FUTIMENS=0; AC_SUBST([REPLACE_FUTIMENS]) diff --git a/m4/time_h.m4 b/m4/time_h.m4 index e4fe59084f8..d0f89327c4b 100644 --- a/m4/time_h.m4 +++ b/m4/time_h.m4 @@ -1,9 +1,8 @@ # Configure a more-standard replacement for <time.h>. -# Copyright (C) 2000-2001, 2003-2007, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2020 Free Software Foundation, Inc. -# serial 11 +# serial 12 # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, @@ -20,10 +19,12 @@ AC_DEFUN([gl_HEADER_TIME_H], AC_DEFUN([gl_HEADER_TIME_H_BODY], [ - AC_REQUIRE([AC_C_RESTRICT]) AC_REQUIRE([gl_HEADER_TIME_H_DEFAULTS]) + gl_NEXT_HEADERS([time.h]) AC_REQUIRE([gl_CHECK_TYPE_STRUCT_TIMESPEC]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) dnl Check whether 'struct timespec' is declared diff --git a/m4/timespec.m4 b/m4/timespec.m4 index 5ed82b109c6..e71628dc318 100644 --- a/m4/timespec.m4 +++ b/m4/timespec.m4 @@ -1,7 +1,6 @@ #serial 15 -# Copyright (C) 2000-2001, 2003-2007, 2009-2020 Free Software -# Foundation, Inc. +# Copyright (C) 2000-2001, 2003-2007, 2009-2020 Free Software Foundation, Inc. # This file is free software; the Free Software Foundation # gives unlimited permission to copy and/or distribute it, diff --git a/m4/unistd_h.m4 b/m4/unistd_h.m4 index 7453866df84..b4734daf603 100644 --- a/m4/unistd_h.m4 +++ b/m4/unistd_h.m4 @@ -1,4 +1,4 @@ -# unistd_h.m4 serial 76 +# unistd_h.m4 serial 81 dnl Copyright (C) 2006-2020 Free Software Foundation, Inc. dnl This file is free software; the Free Software Foundation dnl gives unlimited permission to copy and/or distribute it, @@ -43,11 +43,13 @@ AC_DEFUN([gl_UNISTD_H], #endif ]], [access chdir chown dup dup2 dup3 environ euidaccess faccessat fchdir fchownat fdatasync fsync ftruncate getcwd getdomainname getdtablesize - getgroups gethostname getlogin getlogin_r getpagesize getpass + getentropy getgroups gethostname getlogin getlogin_r getpagesize getpass getusershell setusershell endusershell group_member isatty lchown link linkat lseek pipe pipe2 pread pwrite readlink readlinkat rmdir sethostname sleep symlink symlinkat truncate ttyname_r unlink unlinkat usleep]) + + AC_REQUIRE([AC_C_RESTRICT]) ]) AC_DEFUN([gl_UNISTD_MODULE_INDICATOR], @@ -80,10 +82,12 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], GNULIB_GETCWD=0; AC_SUBST([GNULIB_GETCWD]) GNULIB_GETDOMAINNAME=0; AC_SUBST([GNULIB_GETDOMAINNAME]) GNULIB_GETDTABLESIZE=0; AC_SUBST([GNULIB_GETDTABLESIZE]) + GNULIB_GETENTROPY=0; AC_SUBST([GNULIB_GETENTROPY]) GNULIB_GETGROUPS=0; AC_SUBST([GNULIB_GETGROUPS]) GNULIB_GETHOSTNAME=0; AC_SUBST([GNULIB_GETHOSTNAME]) GNULIB_GETLOGIN=0; AC_SUBST([GNULIB_GETLOGIN]) GNULIB_GETLOGIN_R=0; AC_SUBST([GNULIB_GETLOGIN_R]) + GNULIB_GETOPT_POSIX=0; AC_SUBST([GNULIB_GETOPT_POSIX]) GNULIB_GETPAGESIZE=0; AC_SUBST([GNULIB_GETPAGESIZE]) GNULIB_GETPASS=0; AC_SUBST([GNULIB_GETPASS]) GNULIB_GETUSERSHELL=0; AC_SUBST([GNULIB_GETUSERSHELL]) @@ -116,7 +120,6 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], dnl Assume proper GNU behavior unless another module says otherwise. HAVE_CHOWN=1; AC_SUBST([HAVE_CHOWN]) HAVE_COPY_FILE_RANGE=1; AC_SUBST([HAVE_COPY_FILE_RANGE]) - HAVE_DUP2=1; AC_SUBST([HAVE_DUP2]) HAVE_DUP3=1; AC_SUBST([HAVE_DUP3]) HAVE_EUIDACCESS=1; AC_SUBST([HAVE_EUIDACCESS]) HAVE_FACCESSAT=1; AC_SUBST([HAVE_FACCESSAT]) @@ -126,6 +129,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], HAVE_FSYNC=1; AC_SUBST([HAVE_FSYNC]) HAVE_FTRUNCATE=1; AC_SUBST([HAVE_FTRUNCATE]) HAVE_GETDTABLESIZE=1; AC_SUBST([HAVE_GETDTABLESIZE]) + HAVE_GETENTROPY=1; AC_SUBST([HAVE_GETENTROPY]) HAVE_GETGROUPS=1; AC_SUBST([HAVE_GETGROUPS]) HAVE_GETHOSTNAME=1; AC_SUBST([HAVE_GETHOSTNAME]) HAVE_GETLOGIN=1; AC_SUBST([HAVE_GETLOGIN]) @@ -195,6 +199,7 @@ AC_DEFUN([gl_UNISTD_H_DEFAULTS], REPLACE_UNLINKAT=0; AC_SUBST([REPLACE_UNLINKAT]) REPLACE_USLEEP=0; AC_SUBST([REPLACE_USLEEP]) REPLACE_WRITE=0; AC_SUBST([REPLACE_WRITE]) + UNISTD_H_HAVE_SYS_RANDOM_H=0; AC_SUBST([UNISTD_H_HAVE_SYS_RANDOM_H]) UNISTD_H_HAVE_WINSOCK2_H=0; AC_SUBST([UNISTD_H_HAVE_WINSOCK2_H]) UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS=0; AC_SUBST([UNISTD_H_HAVE_WINSOCK2_H_AND_USE_SOCKETS]) diff --git a/m4/utimensat.m4 b/m4/utimensat.m4 new file mode 100644 index 00000000000..2bc1bfebb5d --- /dev/null +++ b/m4/utimensat.m4 @@ -0,0 +1,69 @@ +# serial 6 +# See if we need to provide utimensat replacement. + +dnl Copyright (C) 2009-2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +# Written by Eric Blake. + +AC_DEFUN([gl_FUNC_UTIMENSAT], +[ + AC_REQUIRE([gl_SYS_STAT_H_DEFAULTS]) + AC_REQUIRE([gl_USE_SYSTEM_EXTENSIONS]) + AC_CHECK_FUNCS_ONCE([utimensat]) + if test $ac_cv_func_utimensat = no; then + HAVE_UTIMENSAT=0 + else + AC_CACHE_CHECK([whether utimensat works], + [gl_cv_func_utimensat_works], + [AC_RUN_IFELSE( + [AC_LANG_PROGRAM([[ +#include <fcntl.h> +#include <sys/stat.h> +#include <unistd.h> +]], [[int result = 0; + const char *f = "conftest.file"; + if (close (creat (f, 0600))) + return 1; + /* Test whether the AT_SYMLINK_NOFOLLOW flag is supported. */ + { + if (utimensat (AT_FDCWD, f, NULL, AT_SYMLINK_NOFOLLOW)) + result |= 2; + } + /* Test whether UTIME_NOW and UTIME_OMIT work. */ + { + struct timespec ts[2]; + ts[0].tv_sec = 1; + ts[0].tv_nsec = UTIME_OMIT; + ts[1].tv_sec = 1; + ts[1].tv_nsec = UTIME_NOW; + if (utimensat (AT_FDCWD, f, ts, 0)) + result |= 4; + } + sleep (1); + { + struct stat st; + struct timespec ts[2]; + ts[0].tv_sec = 1; + ts[0].tv_nsec = UTIME_NOW; + ts[1].tv_sec = 1; + ts[1].tv_nsec = UTIME_OMIT; + if (utimensat (AT_FDCWD, f, ts, 0)) + result |= 8; + if (stat (f, &st)) + result |= 16; + else if (st.st_ctime < st.st_atime) + result |= 32; + } + return result; + ]])], + [gl_cv_func_utimensat_works=yes], + [gl_cv_func_utimensat_works=no], + [gl_cv_func_utimensat_works="guessing yes"])]) + if test "$gl_cv_func_utimensat_works" = no; then + REPLACE_UTIMENSAT=1 + fi + fi +]) diff --git a/m4/zzgnulib.m4 b/m4/zzgnulib.m4 new file mode 100644 index 00000000000..98fa68f51a6 --- /dev/null +++ b/m4/zzgnulib.m4 @@ -0,0 +1,23 @@ +# zzgnulib.m4 serial 1 +dnl Copyright (C) 2020 Free Software Foundation, Inc. +dnl This file is free software; the Free Software Foundation +dnl gives unlimited permission to copy and/or distribute it, +dnl with or without modifications, as long as this notice is preserved. + +dnl This file must be named something that sorts after all other +dnl package- or gnulib-provided .m4 files - at least for those packages +dnl that redefine AC_PROG_CC. + +dnl Redefine AC_PROG_CC so that it ends with invocations of gl_COMPILER_CLANG +dnl and gl_COMPILER_PREPARE_CHECK_DECL. +m4_define([AC_PROG_CC], + m4_defn([AC_PROG_CC])[ +gl_COMPILER_CLANG +gl_COMPILER_PREPARE_CHECK_DECL +]) + +# gl_ZZGNULIB +# ----------- +# Witness macro that this file has been included. Needed to force +# Automake to include this file after all other gnulib .m4 files. +AC_DEFUN([gl_ZZGNULIB]) diff --git a/msdos/sed2v2.inp b/msdos/sed2v2.inp index c1ec9ff0cac..e79dc4600c1 100644 --- a/msdos/sed2v2.inp +++ b/msdos/sed2v2.inp @@ -66,7 +66,7 @@ /^#undef PACKAGE_NAME/s/^.*$/#define PACKAGE_NAME ""/ /^#undef PACKAGE_STRING/s/^.*$/#define PACKAGE_STRING ""/ /^#undef PACKAGE_TARNAME/s/^.*$/#define PACKAGE_TARNAME ""/ -/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "27.1"/ +/^#undef PACKAGE_VERSION/s/^.*$/#define PACKAGE_VERSION "28.0.50"/ /^#undef SYSTEM_TYPE/s/^.*$/#define SYSTEM_TYPE "ms-dos"/ /^#undef HAVE_DECL_GETENV/s/^.*$/#define HAVE_DECL_GETENV 1/ /^#undef SYS_SIGLIST_DECLARED/s/^.*$/#define SYS_SIGLIST_DECLARED 1/ diff --git a/nt/README.W32 b/nt/README.W32 index 8f2e277ecac..9c8d20472a9 100644 --- a/nt/README.W32 +++ b/nt/README.W32 @@ -1,7 +1,7 @@ Copyright (C) 2001-2020 Free Software Foundation, Inc. See the end of the file for license conditions. - Emacs version 27.1 for MS-Windows + Emacs version 28.0.50 for MS-Windows This README file describes how to set up and run a precompiled distribution of the latest version of GNU Emacs for MS-Windows. You diff --git a/nt/gnulib-cfg.mk b/nt/gnulib-cfg.mk index 275fa61d3ff..b84626d903d 100644 --- a/nt/gnulib-cfg.mk +++ b/nt/gnulib-cfg.mk @@ -64,3 +64,7 @@ OMIT_GNULIB_MODULE_sys_types = true OMIT_GNULIB_MODULE_unistd = true OMIT_GNULIB_MODULE_canonicalize-lgpl = true OMIT_GNULIB_MODULE_utimens = true +OMIT_GNULIB_MODULE_fchmodat = true +OMIT_GNULIB_MODULE_lchmod = true +OMIT_GNULIB_MODULE_futimens = true +OMIT_GNULIB_MODULE_utimensat = true diff --git a/nt/inc/ms-w32.h b/nt/inc/ms-w32.h index e5d9fd3e78e..4cbae16dc5a 100644 --- a/nt/inc/ms-w32.h +++ b/nt/inc/ms-w32.h @@ -300,22 +300,6 @@ extern int sys_umask (int); #define execvp _execvp #include <stdint.h> /* for intptr_t */ extern intptr_t _execvp (const char *, char **); -#ifdef MINGW_W64 -/* GCC 6 has a builtin execve with the prototype shown below. MinGW64 - changed the prototype in its process.h to match that, although the - library function still calls _execve, which still returns intptr_t. - However, using the prototype with intptr_t causes GCC to emit - warnings. Fortunately, execve is not used in the MinGW build, but - the code that references it is still compiled. */ -extern int execve (const char *, char * const *, char * const *); -#else -/* mingw.org's MinGW GCC 9.x has the same built-in prototype... */ -# if __GNUC__ >= 9 -extern int execve (const char *, char * const *, char * const *); -# else -extern intptr_t execve (const char *, char * const *, char * const *); -# endif -#endif #define tcdrain _commit #define fdopen _fdopen #define fsync _commit @@ -445,6 +429,7 @@ extern int alarm (int); extern int sys_kill (pid_t, int); +extern void explicit_bzero (void *, size_t); /* For integration with MSDOS support. */ #define getdisk() (_getdrive () - 1) @@ -504,6 +489,8 @@ extern void *malloc_after_dump_9x(size_t); extern void *realloc_after_dump_9x(void *, size_t); extern void free_after_dump_9x(void *); +extern void *sys_calloc(size_t, size_t); + extern malloc_fn the_malloc_fn; extern realloc_fn the_realloc_fn; extern free_fn the_free_fn; @@ -511,6 +498,7 @@ extern free_fn the_free_fn; #define malloc(size) (*the_malloc_fn)(size) #define free(ptr) (*the_free_fn)(ptr) #define realloc(ptr, size) (*the_realloc_fn)(ptr, size) +#define calloc(num, size) sys_calloc(num, size) #endif diff --git a/nt/inc/sys/stat.h b/nt/inc/sys/stat.h index 7bf780dbaa2..f58d5ab6573 100644 --- a/nt/inc/sys/stat.h +++ b/nt/inc/sys/stat.h @@ -164,4 +164,9 @@ int __cdecl __MINGW_NOTHROW fstatat (int, char const *, struct stat *, int); int __cdecl __MINGW_NOTHROW chmod (const char*, int); +/* Provide prototypes of library functions that are emulated on w32 + and whose prototypes are usually found in sys/stat.h on POSIX + platforms. */ +extern int utimensat (int, const char *, struct timespec const[2], int); + #endif /* INC_SYS_STAT_H_ */ diff --git a/nt/mingw-cfg.site b/nt/mingw-cfg.site index dfdca3926f9..4a77cc20b4e 100644 --- a/nt/mingw-cfg.site +++ b/nt/mingw-cfg.site @@ -102,6 +102,14 @@ ac_cv_func_lstat=yes gl_cv_func_lstat_dereferences_slashed_symlink=yes ac_cv_func_fstatat=yes gl_cv_func_fstatat_zero_flag=yes +ac_cv_func_fchmodat=yes +gl_cv_func_fchmodat_works="not-needed-so-yes" +ac_cv_func_lchmod=yes +ac_cv_func_futimens=not-needed +gl_cv_func_futimens_works="not-needed-so-yes" +ac_cv_func_utimensat=yes +gl_cv_func_utimensat_works=yes +ac_cv_func_explicit_bzero=yes # Aliased to _commit in ms-w32.h ac_cv_func_fsync=yes ac_cv_func_fdatasync=yes @@ -145,3 +153,6 @@ gl_cv_warn_c__Wredundant_decls=no # missing prototype, since lib/unistd.h, where Gnulib has its # prototype, isn't built on Windows. gl_cv_func_copy_file_range=yes +# We don't want to build Emacs so it depends on bcrypt.dll, since then +# it will refuse to start on systems where that DLL is absent. +gl_cv_lib_assume_bcrypt=no diff --git a/src/.gdbinit b/src/.gdbinit index 30c7b055ce0..78536fc01fb 100644 --- a/src/.gdbinit +++ b/src/.gdbinit @@ -500,6 +500,9 @@ define pgx # IMAGE_GLYPH if ($g.type == 3) printf "IMAGE[%d]", $g.u.img_id + if ($g.slice.img.x || $g.slice.img.y || $g.slice.img.width || $g.slice.img.height) + printf " slice=%d,%d,%d,%d" ,$g.slice.img.x, $g.slice.img.y, $g.slice.img.width, $g.slice.img.height + end end # STRETCH_GLYPH if ($g.type == 4) @@ -551,9 +554,6 @@ define pgx if ($g.right_box_line_p) printf " ]" end - if ($g.slice.img.x || $g.slice.img.y || $g.slice.img.width || $g.slice.img.height) - printf " slice=%d,%d,%d,%d" ,$g.slice.img.x, $g.slice.img.y, $g.slice.img.width, $g.slice.img.height - end printf "\n" end document pgx diff --git a/src/Makefile.in b/src/Makefile.in index ab63b926272..72d69fb7a3e 100644 --- a/src/Makefile.in +++ b/src/Makefile.in @@ -295,8 +295,8 @@ EMACSRES = @EMACSRES@ W32_RES_LINK=@W32_RES_LINK@ ## Empty if !HAVE_X_WINDOWS -## xfont.o ftfont.o xftfont.o ftxfont.o if HAVE_XFT -## xfont.o ftfont.o ftxfont.o if HAVE_FREETYPE +## xfont.o ftfont.o xftfont.o if HAVE_XFT +## xfont.o ftfont.o if HAVE_FREETYPE ## xfont.o ftfont.o ftcrfont.o if USE_CAIRO ## else xfont.o ## if HAVE_HARFBUZZ, hbfont.o is added regardless of the rest @@ -323,8 +323,7 @@ INTERVALS_H = dispextern.h intervals.h composite.h GETLOADAVG_LIBS = @GETLOADAVG_LIBS@ -GMP_LIB = @GMP_LIB@ -GMP_OBJ = @GMP_OBJ@ +LIB_GMP = @LIB_GMP@ RUN_TEMACS = ./temacs @@ -436,7 +435,7 @@ SOME_MACHINE_OBJECTS = dosfns.o msdos.o \ nsterm.o nsfns.o nsmenu.o nsselect.o nsimage.o nsfont.o macfont.o \ w32.o w32console.o w32cygwinx.o w32fns.o w32heap.o w32inevt.o w32notify.o \ w32menu.o w32proc.o w32reg.o w32select.o w32term.o w32xfns.o \ - w16select.o widget.o xfont.o ftfont.o xftfont.o ftxfont.o gtkutil.o \ + w16select.o widget.o xfont.o ftfont.o xftfont.o gtkutil.o \ xsettings.o xgselect.o termcap.o hbfont.o ## gmalloc.o if !SYSTEM_MALLOC && !DOUG_LEA_MALLOC, else empty. @@ -531,7 +530,7 @@ LIBES = $(LIBS) $(W32_LIBS) $(LIBS_GNUSTEP) $(LIBX_BASE) $(LIBIMAGE) \ $(FREETYPE_LIBS) $(FONTCONFIG_LIBS) $(HARFBUZZ_LIBS) $(LIBOTF_LIBS) $(M17N_FLT_LIBS) \ $(LIBGNUTLS_LIBS) $(LIB_PTHREAD) $(GETADDRINFO_A_LIBS) $(LCMS2_LIBS) \ $(NOTIFY_LIBS) $(LIB_MATH) $(LIBZ) $(LIBMODULES) $(LIBSYSTEMD_LIBS) \ - $(JSON_LIBS) $(GMP_LIB) + $(JSON_LIBS) $(LIB_GMP) ## FORCE it so that admin/unidata can decide whether this file is ## up-to-date. Although since charprop depends on bootstrap-emacs, diff --git a/src/alloc.c b/src/alloc.c index 568fee666fe..ed30c449785 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -67,7 +67,8 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ # include <malloc.h> #endif -#if defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND +#if (defined ENABLE_CHECKING \ + && defined HAVE_VALGRIND_VALGRIND_H && !defined USE_VALGRIND) # define USE_VALGRIND 1 #endif @@ -104,6 +105,66 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for sbrk */ #endif +/* A type with alignment at least as large as any object that Emacs + allocates. This is not max_align_t because some platforms (e.g., + mingw) have buggy malloc implementations that do not align for + max_align_t. This union contains types of all GCALIGNED_STRUCT + components visible here. */ +union emacs_align_type +{ + struct frame frame; + struct Lisp_Bignum Lisp_Bignum; + struct Lisp_Bool_Vector Lisp_Bool_Vector; + struct Lisp_Char_Table Lisp_Char_Table; + struct Lisp_CondVar Lisp_CondVar; + struct Lisp_Finalizer Lisp_Finalizer; + struct Lisp_Float Lisp_Float; + struct Lisp_Hash_Table Lisp_Hash_Table; + struct Lisp_Marker Lisp_Marker; + struct Lisp_Misc_Ptr Lisp_Misc_Ptr; + struct Lisp_Mutex Lisp_Mutex; + struct Lisp_Overlay Lisp_Overlay; + struct Lisp_Sub_Char_Table Lisp_Sub_Char_Table; + struct Lisp_Subr Lisp_Subr; + struct Lisp_User_Ptr Lisp_User_Ptr; + struct Lisp_Vector Lisp_Vector; + struct terminal terminal; + struct thread_state thread_state; + struct window window; + + /* Omit the following since they would require including process.h + etc. In practice their alignments never exceed that of the + structs already listed. */ +#if 0 + struct Lisp_Module_Function Lisp_Module_Function; + struct Lisp_Process Lisp_Process; + struct save_window_data save_window_data; + struct scroll_bar scroll_bar; + struct xwidget_view xwidget_view; + struct xwidget xwidget; +#endif +}; + +/* MALLOC_SIZE_NEAR (N) is a good number to pass to malloc when + allocating a block of memory with size close to N bytes. + For best results N should be a power of 2. + + When calculating how much memory to allocate, GNU malloc (SIZE) + adds sizeof (size_t) to SIZE for internal overhead, and then rounds + up to a multiple of MALLOC_ALIGNMENT. Emacs can improve + performance a bit on GNU platforms by arranging for the resulting + size to be a power of two. This heuristic is good for glibc 2.26 + (2017) and later, and does not affect correctness on other + platforms. */ + +#define MALLOC_SIZE_NEAR(n) \ + (ROUNDUP (max (n, sizeof (size_t)), MALLOC_ALIGNMENT) - sizeof (size_t)) +#ifdef __i386 +enum { MALLOC_ALIGNMENT = 16 }; +#else +enum { MALLOC_ALIGNMENT = max (2 * sizeof (size_t), alignof (long double)) }; +#endif + #ifdef DOUG_LEA_MALLOC /* Specify maximum number of areas to mmap. It would be nice to use a @@ -412,7 +473,6 @@ inline static void set_interval_marked (INTERVAL i); enum mem_type { MEM_TYPE_NON_LISP, - MEM_TYPE_BUFFER, MEM_TYPE_CONS, MEM_TYPE_STRING, MEM_TYPE_SYMBOL, @@ -636,25 +696,19 @@ buffer_memory_full (ptrdiff_t nbytes) #define COMMON_MULTIPLE(a, b) \ ((a) % (b) == 0 ? (a) : (b) % (a) == 0 ? (b) : (a) * (b)) -/* LISP_ALIGNMENT is the alignment of Lisp objects. It must be at - least GCALIGNMENT so that pointers can be tagged. It also must be - at least as strict as the alignment of all the C types used to - implement Lisp objects; since pseudovectors can contain any C type, - this is max_align_t. On recent GNU/Linux x86 and x86-64 this can - often waste up to 8 bytes, since alignof (max_align_t) is 16 but - typical vectors need only an alignment of 8. Although shrinking - the alignment to 8 would save memory, it cost a 20% hit to Emacs - CPU performance on Fedora 28 x86-64 when compiled with gcc -m32. */ -enum { LISP_ALIGNMENT = alignof (union { max_align_t x; +/* Alignment needed for memory blocks that are allocated via malloc + and that contain Lisp objects. On typical hosts malloc already + aligns sufficiently, but extra work is needed on oddball hosts + where Emacs would crash if malloc returned a non-GCALIGNED pointer. */ +enum { LISP_ALIGNMENT = alignof (union { union emacs_align_type x; GCALIGNED_UNION_MEMBER }) }; verify (LISP_ALIGNMENT % GCALIGNMENT == 0); /* True if malloc (N) is known to return storage suitably aligned for Lisp objects whenever N is a multiple of LISP_ALIGNMENT. In practice this is true whenever alignof (max_align_t) is also a - multiple of LISP_ALIGNMENT. This works even for x86, where some - platform combinations (e.g., GCC 7 and later, glibc 2.25 and - earlier) have bugs where alignof (max_align_t) is 16 even though + multiple of LISP_ALIGNMENT. This works even for buggy platforms + like MinGW circa 2020, where alignof (max_align_t) is 16 even though the malloc alignment is only 8, and where Emacs still works because it never does anything that requires an alignment of 16. */ enum { MALLOC_IS_LISP_ALIGNED = alignof (max_align_t) % LISP_ALIGNMENT == 0 }; @@ -694,7 +748,7 @@ malloc_unblock_input (void) malloc_probe (size); \ } while (0) -static void *lmalloc (size_t) ATTRIBUTE_MALLOC_SIZE ((1)); +static void *lmalloc (size_t, bool) ATTRIBUTE_MALLOC_SIZE ((1)); static void *lrealloc (void *, size_t); /* Like malloc but check for no memory and block interrupt input. */ @@ -705,7 +759,7 @@ xmalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, false); MALLOC_UNBLOCK_INPUT; if (!val && size) @@ -722,12 +776,11 @@ xzalloc (size_t size) void *val; MALLOC_BLOCK_INPUT; - val = lmalloc (size); + val = lmalloc (size, true); MALLOC_UNBLOCK_INPUT; if (!val && size) memory_full (size); - memset (val, 0, size); MALLOC_PROBE (size); return val; } @@ -743,7 +796,7 @@ xrealloc (void *block, size_t size) /* We must call malloc explicitly when BLOCK is 0, since some reallocs don't do this. */ if (! block) - val = lmalloc (size); + val = lmalloc (size, false); else val = lrealloc (block, size); MALLOC_UNBLOCK_INPUT; @@ -939,7 +992,7 @@ void *lisp_malloc_loser EXTERNALLY_VISIBLE; #endif static void * -lisp_malloc (size_t nbytes, enum mem_type type) +lisp_malloc (size_t nbytes, bool clearit, enum mem_type type) { register void *val; @@ -949,7 +1002,7 @@ lisp_malloc (size_t nbytes, enum mem_type type) allocated_mem_type = type; #endif - val = lmalloc (nbytes); + val = lmalloc (nbytes, clearit); #if ! USE_LSB_TAG /* If the memory just allocated cannot be addressed thru a Lisp @@ -1290,16 +1343,21 @@ laligned (void *p, size_t size) that's never really exercised) for little benefit. */ static void * -lmalloc (size_t size) +lmalloc (size_t size, bool clearit) { #ifdef USE_ALIGNED_ALLOC if (! MALLOC_IS_LISP_ALIGNED && size % LISP_ALIGNMENT == 0) - return aligned_alloc (LISP_ALIGNMENT, size); + { + void *p = aligned_alloc (LISP_ALIGNMENT, size); + if (clearit && p) + memclear (p, size); + return p; + } #endif while (true) { - void *p = malloc (size); + void *p = clearit ? calloc (1, size) : malloc (size); if (laligned (p, size)) return p; free (p); @@ -1328,11 +1386,11 @@ lrealloc (void *p, size_t size) Interval Allocation ***********************************************************************/ -/* Number of intervals allocated in an interval_block structure. - The 1020 is 1024 minus malloc overhead. */ +/* Number of intervals allocated in an interval_block structure. */ -#define INTERVAL_BLOCK_SIZE \ - ((1020 - sizeof (struct interval_block *)) / sizeof (struct interval)) +enum { INTERVAL_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct interval_block *)) + / sizeof (struct interval)) }; /* Intervals are allocated in chunks in the form of an interval_block structure. */ @@ -1377,7 +1435,7 @@ make_interval (void) if (interval_block_index == INTERVAL_BLOCK_SIZE) { struct interval_block *newi - = lisp_malloc (sizeof *newi, MEM_TYPE_NON_LISP); + = lisp_malloc (sizeof *newi, false, MEM_TYPE_NON_LISP); newi->next = interval_block; interval_block = newi; @@ -1444,10 +1502,9 @@ mark_interval_tree (INTERVAL i) longer used, can be easily recognized, and it's easy to compact the sblocks of small strings which we do in compact_small_strings. */ -/* Size in bytes of an sblock structure used for small strings. This - is 8192 minus malloc overhead. */ +/* Size in bytes of an sblock structure used for small strings. */ -#define SBLOCK_SIZE 8188 +enum { SBLOCK_SIZE = MALLOC_SIZE_NEAR (8192) }; /* Strings larger than this are considered large strings. String data for large strings is allocated from individual sblocks. */ @@ -1522,11 +1579,11 @@ struct sblock sdata data[FLEXIBLE_ARRAY_MEMBER]; }; -/* Number of Lisp strings in a string_block structure. The 1020 is - 1024 minus malloc overhead. */ +/* Number of Lisp strings in a string_block structure. */ -#define STRING_BLOCK_SIZE \ - ((1020 - sizeof (struct string_block *)) / sizeof (struct Lisp_String)) +enum { STRING_BLOCK_SIZE + = ((MALLOC_SIZE_NEAR (1024) - sizeof (struct string_block *)) + / sizeof (struct Lisp_String)) }; /* Structure describing a block from which Lisp_String structures are allocated. */ @@ -1730,7 +1787,7 @@ allocate_string (void) add all the Lisp_Strings in it to the free-list. */ if (string_free_list == NULL) { - struct string_block *b = lisp_malloc (sizeof *b, MEM_TYPE_STRING); + struct string_block *b = lisp_malloc (sizeof *b, false, MEM_TYPE_STRING); int i; b->next = string_blocks; @@ -1778,15 +1835,16 @@ allocate_string (void) plus a NUL byte at the end. Allocate an sdata structure DATA for S, and set S->u.s.data to SDATA->u.data. Store a NUL byte at the end of S->u.s.data. Set S->u.s.size to NCHARS and S->u.s.size_byte - to NBYTES. Free S->u.s.data if it was initially non-null. */ + to NBYTES. Free S->u.s.data if it was initially non-null. -void + If CLEARIT, also clear the other bytes of S->u.s.data. */ + +static void allocate_string_data (struct Lisp_String *s, - EMACS_INT nchars, EMACS_INT nbytes) + EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { - sdata *data, *old_data; + sdata *data; struct sblock *b; - ptrdiff_t old_nbytes; if (STRING_BYTES_MAX < nbytes) string_overflow (); @@ -1794,13 +1852,6 @@ allocate_string_data (struct Lisp_String *s, /* Determine the number of bytes needed to store NBYTES bytes of string data. */ ptrdiff_t needed = sdata_size (nbytes); - if (s->u.s.data) - { - old_data = SDATA_OF_STRING (s); - old_nbytes = STRING_BYTES (s); - } - else - old_data = NULL; MALLOC_BLOCK_INPUT; @@ -1813,7 +1864,7 @@ allocate_string_data (struct Lisp_String *s, mallopt (M_MMAP_MAX, 0); #endif - b = lisp_malloc (size + GC_STRING_EXTRA, MEM_TYPE_NON_LISP); + b = lisp_malloc (size + GC_STRING_EXTRA, clearit, MEM_TYPE_NON_LISP); #ifdef DOUG_LEA_MALLOC if (!mmap_lisp_allowed_p ()) @@ -1825,27 +1876,30 @@ allocate_string_data (struct Lisp_String *s, b->next_free = data; large_sblocks = b; } - else if (current_sblock == NULL - || (((char *) current_sblock + SBLOCK_SIZE - - (char *) current_sblock->next_free) - < (needed + GC_STRING_EXTRA))) - { - /* Not enough room in the current sblock. */ - b = lisp_malloc (SBLOCK_SIZE, MEM_TYPE_NON_LISP); - data = b->data; - b->next = NULL; - b->next_free = data; - - if (current_sblock) - current_sblock->next = b; - else - oldest_sblock = b; - current_sblock = b; - } else { b = current_sblock; + + if (b == NULL + || (SBLOCK_SIZE - GC_STRING_EXTRA + < (char *) b->next_free - (char *) b + needed)) + { + /* Not enough room in the current sblock. */ + b = lisp_malloc (SBLOCK_SIZE, false, MEM_TYPE_NON_LISP); + data = b->data; + b->next = NULL; + b->next_free = data; + + if (current_sblock) + current_sblock->next = b; + else + oldest_sblock = b; + current_sblock = b; + } + data = b->next_free; + if (clearit) + memset (SDATA_DATA (data), 0, nbytes); } data->string = s; @@ -1866,16 +1920,55 @@ allocate_string_data (struct Lisp_String *s, GC_STRING_OVERRUN_COOKIE_SIZE); #endif - /* Note that Faset may call to this function when S has already data - assigned. In this case, mark data as free by setting it's string - back-pointer to null, and record the size of the data in it. */ - if (old_data) + tally_consing (needed); +} + +/* Reallocate multibyte STRING data when a single character is replaced. + The character is at byte offset CIDX_BYTE in the string. + The character being replaced is CLEN bytes long, + and the character that will replace it is NEW_CLEN bytes long. + Return the address of where the caller should store the + the new character. */ + +unsigned char * +resize_string_data (Lisp_Object string, ptrdiff_t cidx_byte, + int clen, int new_clen) +{ + eassume (STRING_MULTIBYTE (string)); + sdata *old_sdata = SDATA_OF_STRING (XSTRING (string)); + ptrdiff_t nchars = SCHARS (string); + ptrdiff_t nbytes = SBYTES (string); + ptrdiff_t new_nbytes = nbytes + (new_clen - clen); + unsigned char *data = SDATA (string); + unsigned char *new_charaddr; + + if (sdata_size (nbytes) == sdata_size (new_nbytes)) { - SDATA_NBYTES (old_data) = old_nbytes; - old_data->string = NULL; + /* No need to reallocate, as the size change falls within the + alignment slop. */ + XSTRING (string)->u.s.size_byte = new_nbytes; + new_charaddr = data + cidx_byte; + memmove (new_charaddr + new_clen, new_charaddr + clen, + nbytes - (cidx_byte + (clen - 1))); + } + else + { + allocate_string_data (XSTRING (string), nchars, new_nbytes, false); + unsigned char *new_data = SDATA (string); + new_charaddr = new_data + cidx_byte; + memcpy (new_charaddr + new_clen, data + cidx_byte + clen, + nbytes - (cidx_byte + clen)); + memcpy (new_data, data, cidx_byte); + + /* Mark old string data as free by setting its string back-pointer + to null, and record the size of the data in it. */ + SDATA_NBYTES (old_sdata) = nbytes; + old_sdata->string = NULL; } - tally_consing (needed); + clear_string_char_byte_cache (); + + return new_charaddr; } @@ -2110,6 +2203,9 @@ string_overflow (void) error ("Maximum string size exceeded"); } +static Lisp_Object make_clear_string (EMACS_INT, bool); +static Lisp_Object make_clear_multibyte_string (EMACS_INT, EMACS_INT, bool); + DEFUN ("make-string", Fmake_string, Smake_string, 2, 3, 0, doc: /* Return a newly created string of length LENGTH, with INIT in each element. LENGTH must be an integer. @@ -2118,19 +2214,20 @@ If optional argument MULTIBYTE is non-nil, the result will be a multibyte string even if INIT is an ASCII character. */) (Lisp_Object length, Lisp_Object init, Lisp_Object multibyte) { - register Lisp_Object val; - int c; + Lisp_Object val; EMACS_INT nbytes; CHECK_FIXNAT (length); CHECK_CHARACTER (init); - c = XFIXNAT (init); + int c = XFIXNAT (init); + bool clearit = !c; + if (ASCII_CHAR_P (c) && NILP (multibyte)) { nbytes = XFIXNUM (length); - val = make_uninit_string (nbytes); - if (nbytes) + val = make_clear_string (nbytes, clearit); + if (nbytes && !clearit) { memset (SDATA (val), c, nbytes); SDATA (val)[nbytes] = 0; @@ -2141,26 +2238,27 @@ a multibyte string even if INIT is an ASCII character. */) unsigned char str[MAX_MULTIBYTE_LENGTH]; ptrdiff_t len = CHAR_STRING (c, str); EMACS_INT string_len = XFIXNUM (length); - unsigned char *p, *beg, *end; if (INT_MULTIPLY_WRAPV (len, string_len, &nbytes)) string_overflow (); - val = make_uninit_multibyte_string (string_len, nbytes); - for (beg = SDATA (val), p = beg, end = beg + nbytes; p < end; p += len) + val = make_clear_multibyte_string (string_len, nbytes, clearit); + if (!clearit) { - /* First time we just copy `str' to the data of `val'. */ - if (p == beg) - memcpy (p, str, len); - else + unsigned char *beg = SDATA (val), *end = beg + nbytes; + for (unsigned char *p = beg; p < end; p += len) { - /* Next time we copy largest possible chunk from - initialized to uninitialized part of `val'. */ - len = min (p - beg, end - p); - memcpy (p, beg, len); + /* First time we just copy STR to the data of VAL. */ + if (p == beg) + memcpy (p, str, len); + else + { + /* Next time we copy largest possible chunk from + initialized to uninitialized part of VAL. */ + len = min (p - beg, end - p); + memcpy (p, beg, len); + } } } - if (nbytes) - *p = 0; } return val; @@ -2330,26 +2428,37 @@ make_specified_string (const char *contents, /* Return a unibyte Lisp_String set up to hold LENGTH characters - occupying LENGTH bytes. */ + occupying LENGTH bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_string (EMACS_INT length) +static Lisp_Object +make_clear_string (EMACS_INT length, bool clearit) { Lisp_Object val; if (!length) return empty_unibyte_string; - val = make_uninit_multibyte_string (length, length); + val = make_clear_multibyte_string (length, length, clearit); STRING_SET_UNIBYTE (val); return val; } +/* Return a unibyte Lisp_String set up to hold LENGTH characters + occupying LENGTH bytes. */ + +Lisp_Object +make_uninit_string (EMACS_INT length) +{ + return make_clear_string (length, false); +} + /* Return a multibyte Lisp_String set up to hold NCHARS characters - which occupy NBYTES bytes. */ + which occupy NBYTES bytes. If CLEARIT, clear its contents to null + bytes; otherwise, the contents are uninitialized. */ -Lisp_Object -make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +static Lisp_Object +make_clear_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes, bool clearit) { Lisp_Object string; struct Lisp_String *s; @@ -2361,12 +2470,21 @@ make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) s = allocate_string (); s->u.s.intervals = NULL; - allocate_string_data (s, nchars, nbytes); + allocate_string_data (s, nchars, nbytes, clearit); XSETSTRING (string, s); string_chars_consed += nbytes; return string; } +/* Return a multibyte Lisp_String set up to hold NCHARS characters + which occupy NBYTES bytes. */ + +Lisp_Object +make_uninit_multibyte_string (EMACS_INT nchars, EMACS_INT nbytes) +{ + return make_clear_multibyte_string (nchars, nbytes, false); +} + /* Print arguments to BUF according to a FORMAT, then return a Lisp_String initialized with the data from BUF. */ @@ -3023,6 +3141,14 @@ cleanup_vector (struct Lisp_Vector *vector) if (uptr->finalizer) uptr->finalizer (uptr->p); } +#ifdef HAVE_MODULES + else if (PSEUDOVECTOR_TYPEP (&vector->header, PVEC_MODULE_FUNCTION)) + { + ATTRIBUTE_MAY_ALIAS struct Lisp_Module_Function *function + = (struct Lisp_Module_Function *) vector; + module_finalize_function (function); + } +#endif } /* Reclaim space used by unmarked vectors. */ @@ -3137,7 +3263,7 @@ sweep_vectors (void) at most VECTOR_ELTS_MAX. */ static struct Lisp_Vector * -allocate_vectorlike (ptrdiff_t len) +allocate_vectorlike (ptrdiff_t len, bool clearit) { eassert (0 < len && len <= VECTOR_ELTS_MAX); ptrdiff_t nbytes = header_size + len * word_size; @@ -3151,11 +3277,15 @@ allocate_vectorlike (ptrdiff_t len) #endif if (nbytes <= VBLOCK_BYTES_MAX) - p = allocate_vector_from_block (vroundup (nbytes)); + { + p = allocate_vector_from_block (vroundup (nbytes)); + if (clearit) + memclear (p, nbytes); + } else { struct large_vector *lv = lisp_malloc (large_vector_offset + nbytes, - MEM_TYPE_VECTORLIKE); + clearit, MEM_TYPE_VECTORLIKE); lv->next = large_vectors; large_vectors = lv; p = large_vector_vec (lv); @@ -3178,20 +3308,37 @@ allocate_vectorlike (ptrdiff_t len) } -/* Allocate a vector with LEN slots. */ +/* Allocate a vector with LEN slots. If CLEARIT, clear its slots; + otherwise the vector's slots are uninitialized. */ -struct Lisp_Vector * -allocate_vector (ptrdiff_t len) +static struct Lisp_Vector * +allocate_clear_vector (ptrdiff_t len, bool clearit) { if (len == 0) return XVECTOR (zero_vector); if (VECTOR_ELTS_MAX < len) memory_full (SIZE_MAX); - struct Lisp_Vector *v = allocate_vectorlike (len); + struct Lisp_Vector *v = allocate_vectorlike (len, clearit); v->header.size = len; return v; } +/* Allocate a vector with LEN uninitialized slots. */ + +struct Lisp_Vector * +allocate_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, false); +} + +/* Allocate a vector with LEN nil slots. */ + +struct Lisp_Vector * +allocate_nil_vector (ptrdiff_t len) +{ + return allocate_clear_vector (len, true); +} + /* Allocate other vector-like structures. */ @@ -3208,7 +3355,7 @@ allocate_pseudovector (int memlen, int lisplen, eassert (lisplen <= size_max); eassert (memlen <= size_max + rest_max); - struct Lisp_Vector *v = allocate_vectorlike (memlen); + struct Lisp_Vector *v = allocate_vectorlike (memlen, false); /* Only the first LISPLEN slots will be traced normally by the GC. */ memclear (v->contents, zerolen * word_size); XSETPVECTYPESIZE (v, tag, lisplen, memlen - lisplen); @@ -3218,12 +3365,10 @@ allocate_pseudovector (int memlen, int lisplen, struct buffer * allocate_buffer (void) { - struct buffer *b = lisp_malloc (sizeof *b, MEM_TYPE_BUFFER); - + struct buffer *b + = ALLOCATE_PSEUDOVECTOR (struct buffer, cursor_in_non_selected_windows_, + PVEC_BUFFER); BUFFER_PVEC_INIT (b); - /* Put B on the chain of all buffers including killed ones. */ - b->next = all_buffers; - all_buffers = b; /* Note that the rest fields of B are not initialized. */ return b; } @@ -3238,7 +3383,7 @@ allocate_record (EMACS_INT count) if (count > PSEUDOVECTOR_SIZE_MASK) error ("Attempt to allocate a record of %"pI"d slots; max is %d", count, PSEUDOVECTOR_SIZE_MASK); - struct Lisp_Vector *p = allocate_vectorlike (count); + struct Lisp_Vector *p = allocate_vectorlike (count, false); p->header.size = count; XSETPVECTYPE (p, PVEC_RECORD); return p; @@ -3291,9 +3436,11 @@ See also the function `vector'. */) Lisp_Object make_vector (ptrdiff_t length, Lisp_Object init) { - struct Lisp_Vector *p = allocate_vector (length); - for (ptrdiff_t i = 0; i < length; i++) - p->contents[i] = init; + bool clearit = NIL_IS_ZERO && NILP (init); + struct Lisp_Vector *p = allocate_clear_vector (length, clearit); + if (!clearit) + for (ptrdiff_t i = 0; i < length; i++) + p->contents[i] = init; return make_lisp_ptr (p, Lisp_Vectorlike); } @@ -3309,23 +3456,6 @@ usage: (vector &rest OBJECTS) */) return val; } -void -make_byte_code (struct Lisp_Vector *v) -{ - /* Don't allow the global zero_vector to become a byte code object. */ - eassert (0 < v->header.size); - - if (v->header.size > 1 && STRINGP (v->contents[1]) - && STRING_MULTIBYTE (v->contents[1])) - /* BYTECODE-STRING must have been produced by Emacs 20.2 or the - earlier because they produced a raw 8-bit string for byte-code - and now such a byte-code string is loaded as multibyte while - raw 8-bit characters converted to multibyte form. Thus, now we - must convert them back to the original unibyte form. */ - v->contents[1] = Fstring_as_unibyte (v->contents[1]); - XSETPVECTYPE (v, PVEC_COMPILED); -} - DEFUN ("make-byte-code", Fmake_byte_code, Smake_byte_code, 4, MANY, 0, doc: /* Create a byte-code object with specified arguments as elements. The arguments should be the ARGLIST, bytecode-string BYTE-CODE, constant @@ -3344,8 +3474,14 @@ stack before executing the byte-code. usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INTERACTIVE-SPEC &rest ELEMENTS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object val = make_uninit_vector (nargs); - struct Lisp_Vector *p = XVECTOR (val); + if (! ((FIXNUMP (args[COMPILED_ARGLIST]) + || CONSP (args[COMPILED_ARGLIST]) + || NILP (args[COMPILED_ARGLIST])) + && STRINGP (args[COMPILED_BYTECODE]) + && !STRING_MULTIBYTE (args[COMPILED_BYTECODE]) + && VECTORP (args[COMPILED_CONSTANTS]) + && FIXNATP (args[COMPILED_STACK_DEPTH]))) + error ("Invalid byte-code object"); /* We used to purecopy everything here, if purify-flag was set. This worked OK for Emacs-23, but with Emacs-24's lexical binding code, it can be @@ -3354,10 +3490,8 @@ usage: (make-byte-code ARGLIST BYTE-CODE CONSTANTS DEPTH &optional DOCSTRING INT copied into pure space, including its free variables, which is sometimes just wasteful and other times plainly wrong (e.g. those free vars may want to be setcar'd). */ - - memcpy (p->contents, args, nargs * sizeof *args); - make_byte_code (p); - XSETCOMPILED (val, p); + Lisp_Object val = Fvector (nargs, args); + XSETPVECTYPE (XVECTOR (val), PVEC_COMPILED); return val; } @@ -3442,7 +3576,7 @@ Its value is void, and its function definition and property list are nil. */) if (symbol_block_index == SYMBOL_BLOCK_SIZE) { struct symbol_block *new - = lisp_malloc (sizeof *new, MEM_TYPE_SYMBOL); + = lisp_malloc (sizeof *new, false, MEM_TYPE_SYMBOL); new->next = symbol_block; symbol_block = new; symbol_block_index = 0; @@ -3904,10 +4038,10 @@ refill_memory_reserve (void) MEM_TYPE_SPARE); if (spare_memory[5] == 0) spare_memory[5] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[6] == 0) spare_memory[6] = lisp_malloc (sizeof (struct string_block), - MEM_TYPE_SPARE); + false, MEM_TYPE_SPARE); if (spare_memory[0] && spare_memory[1] && spare_memory[5]) Vmemory_full = Qnil; #endif @@ -4304,7 +4438,7 @@ mem_delete_fixup (struct mem_node *x) /* If P is a pointer into a live Lisp string object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. This and other *_holding functions look for a pointer anywhere into @@ -4312,103 +4446,97 @@ mem_delete_fixup (struct mem_node *x) because some compilers sometimes optimize away the latter. See Bug#28213. */ -static Lisp_Object +static struct Lisp_String * live_string_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_STRING) - { - struct string_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->strings[0]; + eassert (m->type == MEM_TYPE_STRING); + struct string_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->strings[0]; - /* P must point into a Lisp_String structure, and it - must not be on the free-list. */ - if (0 <= offset && offset < STRING_BLOCK_SIZE * sizeof b->strings[0]) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; - if (s->u.s.data) - return make_lisp_ptr (s, Lisp_String); - } + /* P must point into a Lisp_String structure, and it + must not be on the free-list. */ + if (0 <= offset && offset < sizeof b->strings) + { + cp = ptr_bounds_copy (cp, b); + struct Lisp_String *s = p = cp -= offset % sizeof b->strings[0]; + if (s->u.s.data) + return s; } - return Qnil; + return NULL; } static bool live_string_p (struct mem_node *m, void *p) { - return !NILP (live_string_holding (m, p)); + return live_string_holding (m, p) == p; } /* If P is a pointer into a live Lisp cons object on the heap, return - the object. Otherwise, return nil. M is a pointer to the + the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Cons * live_cons_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_CONS) + eassert (m->type == MEM_TYPE_CONS); + struct cons_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->conses[0]; + + /* P must point into a Lisp_Cons, not be + one of the unused cells in the current cons block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->conses + && (b != cons_block + || offset / sizeof b->conses[0] < cons_block_index)) { - struct cons_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->conses[0]; - - /* P must point into a Lisp_Cons, not be - one of the unused cells in the current cons block, - and not be on the free-list. */ - if (0 <= offset && offset < CONS_BLOCK_SIZE * sizeof b->conses[0] - && (b != cons_block - || offset / sizeof b->conses[0] < cons_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; - if (!deadp (s->u.s.car)) - return make_lisp_ptr (s, Lisp_Cons); - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Cons *s = p = cp -= offset % sizeof b->conses[0]; + if (!deadp (s->u.s.car)) + return s; } - return Qnil; + return NULL; } static bool live_cons_p (struct mem_node *m, void *p) { - return !NILP (live_cons_holding (m, p)); + return live_cons_holding (m, p) == p; } /* If P is a pointer into a live Lisp symbol object on the heap, - return the object. Otherwise, return nil. M is a pointer to the + return the object's address. Otherwise, return NULL. M points to the mem_block for P. */ -static Lisp_Object +static struct Lisp_Symbol * live_symbol_holding (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_SYMBOL) + eassert (m->type == MEM_TYPE_SYMBOL); + struct symbol_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->symbols[0]; + + /* P must point into the Lisp_Symbol, not be + one of the unused cells in the current symbol block, + and not be on the free-list. */ + if (0 <= offset && offset < sizeof b->symbols + && (b != symbol_block + || offset / sizeof b->symbols[0] < symbol_block_index)) { - struct symbol_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->symbols[0]; - - /* P must point into the Lisp_Symbol, not be - one of the unused cells in the current symbol block, - and not be on the free-list. */ - if (0 <= offset && offset < SYMBOL_BLOCK_SIZE * sizeof b->symbols[0] - && (b != symbol_block - || offset / sizeof b->symbols[0] < symbol_block_index)) - { - cp = ptr_bounds_copy (cp, b); - struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; - if (!deadp (s->u.s.function)) - return make_lisp_symbol (s); - } + cp = ptr_bounds_copy (cp, b); + struct Lisp_Symbol *s = p = cp -= offset % sizeof b->symbols[0]; + if (!deadp (s->u.s.function)) + return s; } - return Qnil; + return NULL; } static bool live_symbol_p (struct mem_node *m, void *p) { - return !NILP (live_symbol_holding (m, p)); + return live_symbol_holding (m, p) == p; } @@ -4418,97 +4546,70 @@ live_symbol_p (struct mem_node *m, void *p) static bool live_float_p (struct mem_node *m, void *p) { - if (m->type == MEM_TYPE_FLOAT) - { - struct float_block *b = m->start; - char *cp = p; - ptrdiff_t offset = cp - (char *) &b->floats[0]; - - /* P must point to the start of a Lisp_Float and not be - one of the unused cells in the current float block. */ - return (offset >= 0 - && offset % sizeof b->floats[0] == 0 - && offset < (FLOAT_BLOCK_SIZE * sizeof b->floats[0]) - && (b != float_block - || offset / sizeof b->floats[0] < float_block_index)); - } - else - return 0; + eassert (m->type == MEM_TYPE_FLOAT); + struct float_block *b = m->start; + char *cp = p; + ptrdiff_t offset = cp - (char *) &b->floats[0]; + + /* P must point to the start of a Lisp_Float and not be + one of the unused cells in the current float block. */ + return (0 <= offset && offset < sizeof b->floats + && offset % sizeof b->floats[0] == 0 + && (b != float_block + || offset / sizeof b->floats[0] < float_block_index)); } -/* If P is a pointer to a live vector-like object, return the object. +/* If P is a pointer to a live, large vector-like object, return the object. Otherwise, return nil. M is a pointer to the mem_block for P. */ -static Lisp_Object -live_vector_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_large_vector_holding (struct mem_node *m, void *p) { + eassert (m->type == MEM_TYPE_VECTORLIKE); struct Lisp_Vector *vp = p; - - if (m->type == MEM_TYPE_VECTOR_BLOCK) - { - /* This memory node corresponds to a vector block. */ - struct vector_block *block = m->start; - struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; - - /* P is in the block's allocation range. Scan the block - up to P and see whether P points to the start of some - vector which is not on a free list. FIXME: check whether - some allocation patterns (probably a lot of short vectors) - may cause a substantial overhead of this loop. */ - while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) - { - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) - return make_lisp_ptr (vector, Lisp_Vectorlike); - vector = next; - } - } - else if (m->type == MEM_TYPE_VECTORLIKE) - { - /* This memory node corresponds to a large vector. */ - struct Lisp_Vector *vector = large_vector_vec (m->start); - struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); - if (vector <= vp && vp < next) - return make_lisp_ptr (vector, Lisp_Vectorlike); - } - return Qnil; + struct Lisp_Vector *vector = large_vector_vec (m->start); + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + return vector <= vp && vp < next ? vector : NULL; } static bool -live_vector_p (struct mem_node *m, void *p) +live_large_vector_p (struct mem_node *m, void *p) { - return !NILP (live_vector_holding (m, p)); + return live_large_vector_holding (m, p) == p; } -/* If P is a pointer into a live buffer, return the buffer. - Otherwise, return nil. M is a pointer to the mem_block for P. */ +/* If P is a pointer to a live, small vector-like object, return the object. + Otherwise, return NULL. + M is a pointer to the mem_block for P. */ -static Lisp_Object -live_buffer_holding (struct mem_node *m, void *p) +static struct Lisp_Vector * +live_small_vector_holding (struct mem_node *m, void *p) { - /* P must point into the block, and the buffer - must not have been killed. */ - if (m->type == MEM_TYPE_BUFFER) + eassert (m->type == MEM_TYPE_VECTOR_BLOCK); + struct Lisp_Vector *vp = p; + struct vector_block *block = m->start; + struct Lisp_Vector *vector = (struct Lisp_Vector *) block->data; + + /* P is in the block's allocation range. Scan the block + up to P and see whether P points to the start of some + vector which is not on a free list. FIXME: check whether + some allocation patterns (probably a lot of short vectors) + may cause a substantial overhead of this loop. */ + while (VECTOR_IN_BLOCK (vector, block) && vector <= vp) { - struct buffer *b = m->start; - char *cb = m->start; - char *cp = p; - ptrdiff_t offset = cp - cb; - if (0 <= offset && offset < sizeof *b && !NILP (b->name_)) - { - Lisp_Object obj; - XSETBUFFER (obj, b); - return obj; - } + struct Lisp_Vector *next = ADVANCE (vector, vector_nbytes (vector)); + if (vp < next && !PSEUDOVECTOR_TYPEP (&vector->header, PVEC_FREE)) + return vector; + vector = next; } - return Qnil; + return NULL; } static bool -live_buffer_p (struct mem_node *m, void *p) +live_small_vector_p (struct mem_node *m, void *p) { - return !NILP (live_buffer_holding (m, p)); + return live_small_vector_holding (m, p) == p; } /* Mark OBJ if we can prove it's a Lisp_Object. */ @@ -4520,10 +4621,24 @@ mark_maybe_object (Lisp_Object obj) VALGRIND_MAKE_MEM_DEFINED (&obj, sizeof (obj)); #endif - if (FIXNUMP (obj)) - return; + int type_tag = XTYPE (obj); + intptr_t offset; + + switch (type_tag) + { + case_Lisp_Int: case Lisp_Type_Unused0: + return; + + case Lisp_Symbol: + offset = (intptr_t) lispsym; + break; - void *po = XPNTR (obj); + default: + offset = 0; + break; + } + + void *po = (char *) XLP (obj) + (offset - LISP_WORD_TAG (type_tag)); /* If the pointer is in the dump image and the dump has a record of the object starting at the place where the pointer points, we @@ -4535,7 +4650,7 @@ mark_maybe_object (Lisp_Object obj) /* Don't use pdumper_object_p_precise here! It doesn't check the tag bits. OBJ here might be complete garbage, so we need to verify both the pointer and the tag. */ - if (XTYPE (obj) == pdumper_find_object_type (po)) + if (pdumper_find_object_type (po) == type_tag) mark_object (obj); return; } @@ -4546,31 +4661,33 @@ mark_maybe_object (Lisp_Object obj) { bool mark_p = false; - switch (XTYPE (obj)) + switch (type_tag) { case Lisp_String: - mark_p = EQ (obj, live_string_holding (m, po)); + mark_p = m->type == MEM_TYPE_STRING && live_string_p (m, po); break; case Lisp_Cons: - mark_p = EQ (obj, live_cons_holding (m, po)); + mark_p = m->type == MEM_TYPE_CONS && live_cons_p (m, po); break; case Lisp_Symbol: - mark_p = EQ (obj, live_symbol_holding (m, po)); + mark_p = m->type == MEM_TYPE_SYMBOL && live_symbol_p (m, po); break; case Lisp_Float: - mark_p = live_float_p (m, po); + mark_p = m->type == MEM_TYPE_FLOAT && live_float_p (m, po); break; case Lisp_Vectorlike: - mark_p = (EQ (obj, live_vector_holding (m, po)) - || EQ (obj, live_buffer_holding (m, po))); + mark_p = (m->type == MEM_TYPE_VECTOR_BLOCK + ? live_small_vector_p (m, po) + : (m->type == MEM_TYPE_VECTORLIKE + && live_large_vector_p (m, po))); break; default: - break; + eassume (false); } if (mark_p) @@ -4593,7 +4710,7 @@ mark_maybe_pointer (void *p) { struct mem_node *m; -#ifdef USE_VALGRIND +#if USE_VALGRIND VALGRIND_MAKE_MEM_DEFINED (&p, sizeof (p)); #endif @@ -4611,47 +4728,71 @@ mark_maybe_pointer (void *p) m = mem_find (p); if (m != MEM_NIL) { - Lisp_Object obj = Qnil; + Lisp_Object obj; switch (m->type) { case MEM_TYPE_NON_LISP: case MEM_TYPE_SPARE: /* Nothing to do; not a pointer to Lisp memory. */ - break; - - case MEM_TYPE_BUFFER: - obj = live_buffer_holding (m, p); - break; + return; case MEM_TYPE_CONS: - obj = live_cons_holding (m, p); + { + struct Lisp_Cons *h = live_cons_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Cons); + } break; case MEM_TYPE_STRING: - obj = live_string_holding (m, p); + { + struct Lisp_String *h = live_string_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_String); + } break; case MEM_TYPE_SYMBOL: - obj = live_symbol_holding (m, p); + { + struct Lisp_Symbol *h = live_symbol_holding (m, p); + if (!h) + return; + obj = make_lisp_symbol (h); + } break; case MEM_TYPE_FLOAT: - if (live_float_p (m, p)) - obj = make_lisp_ptr (p, Lisp_Float); + if (! live_float_p (m, p)) + return; + obj = make_lisp_ptr (p, Lisp_Float); break; case MEM_TYPE_VECTORLIKE: + { + struct Lisp_Vector *h = live_large_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } + break; + case MEM_TYPE_VECTOR_BLOCK: - obj = live_vector_holding (m, p); + { + struct Lisp_Vector *h = live_small_vector_holding (m, p); + if (!h) + return; + obj = make_lisp_ptr (h, Lisp_Vectorlike); + } break; default: emacs_abort (); } - if (!NILP (obj)) - mark_object (obj); + mark_object (obj); } } @@ -4815,9 +4956,10 @@ test_setjmp (void) as a stack scan limit. */ typedef union { - /* Align the stack top properly. Even if !HAVE___BUILTIN_UNWIND_INIT, - jmp_buf may not be aligned enough on darwin-ppc64. */ - max_align_t o; + /* Make sure stack_top and m_stack_bottom are properly aligned as GC + expects. */ + Lisp_Object o; + void *p; #ifndef HAVE___BUILTIN_UNWIND_INIT sys_jmp_buf j; char c; @@ -4861,12 +5003,10 @@ typedef union #ifdef HAVE___BUILTIN_UNWIND_INIT # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ *(p) = NEAR_STACK_TOP (&sentry) #else # define SET_STACK_TOP_ADDRESS(p) \ stacktop_sentry sentry; \ - __builtin_unwind_init (); \ test_setjmp (); \ sys_setjmp (sentry.j); \ *(p) = NEAR_STACK_TOP (&sentry + (stack_bottom < &sentry.c)) @@ -4930,8 +5070,9 @@ mark_stack (char const *bottom, char const *end) #endif } -/* This is a trampoline function that flushes registers to the stack, - and then calls FUNC. ARG is passed through to FUNC verbatim. +/* flush_stack_call_func is the trampoline function that flushes + registers to the stack, and then calls FUNC. ARG is passed through + to FUNC verbatim. This function must be called whenever Emacs is about to release the global interpreter lock. This lets the garbage collector easily @@ -4939,10 +5080,23 @@ mark_stack (char const *bottom, char const *end) Lisp. It is invalid to run any Lisp code or to allocate any GC memory - from FUNC. */ + from FUNC. + + Note: all register spilling is done in flush_stack_call_func before + flush_stack_call_func1 is activated. + + flush_stack_call_func1 is responsible for identifying the stack + address range to be scanned. It *must* be carefully kept as + noinline to make sure that registers has been spilled before it is + called, otherwise given __builtin_frame_address (0) typically + returns the frame pointer (base pointer) and not the stack pointer + [1] GC will miss to scan callee-saved registers content + (Bug#41357). + + [1] <https://gcc.gnu.org/onlinedocs/gcc/Return-Address.html>. */ NO_INLINE void -flush_stack_call_func (void (*func) (void *arg), void *arg) +flush_stack_call_func1 (void (*func) (void *arg), void *arg) { void *end; struct thread_state *self = current_thread; @@ -5032,9 +5186,6 @@ valid_lisp_object_p (Lisp_Object obj) case MEM_TYPE_SPARE: return 0; - case MEM_TYPE_BUFFER: - return live_buffer_p (m, p) ? 1 : 2; - case MEM_TYPE_CONS: return live_cons_p (m, p); @@ -5048,8 +5199,10 @@ valid_lisp_object_p (Lisp_Object obj) return live_float_p (m, p); case MEM_TYPE_VECTORLIKE: + return live_large_vector_p (m, p); + case MEM_TYPE_VECTOR_BLOCK: - return live_vector_p (m, p); + return live_small_vector_p (m, p); default: break; @@ -5571,7 +5724,7 @@ compact_font_cache_entry (Lisp_Object entry) struct font *font = GC_XFONT_OBJECT (val); if (!NILP (AREF (val, FONT_TYPE_INDEX)) - && vectorlike_marked_p(&font->header)) + && vectorlike_marked_p (&font->header)) break; } if (CONSP (objlist)) @@ -5851,7 +6004,7 @@ maybe_garbage_collect (void) void garbage_collect (void) { - struct buffer *nextb; + Lisp_Object tail, buffer; char stack_top_variable; bool message_p; ptrdiff_t count = SPECPDL_INDEX (); @@ -5867,8 +6020,8 @@ garbage_collect (void) /* Don't keep undo information around forever. Do this early on, so it is no problem if the user quits. */ - FOR_EACH_BUFFER (nextb) - compact_buffer (nextb); + FOR_EACH_LIVE_BUFFER (tail, buffer) + compact_buffer (XBUFFER (buffer)); byte_ct tot_before = (profiler_memory_running ? total_bytes_of_live_objects () @@ -5958,8 +6111,9 @@ garbage_collect (void) compact_font_caches (); - FOR_EACH_BUFFER (nextb) + FOR_EACH_LIVE_BUFFER (tail, buffer) { + struct buffer *nextb = XBUFFER (buffer); if (!EQ (BVAR (nextb, undo_list), Qt)) bset_undo_list (nextb, compact_undo_list (BVAR (nextb, undo_list))); /* Now that we have stripped the elements that need not be @@ -6224,7 +6378,12 @@ mark_buffer (struct buffer *buffer) /* For now, we just don't mark the undo_list. It's done later in a special way just before the sweep phase, and after stripping - some of its elements that are not needed any more. */ + some of its elements that are not needed any more. + Note: this later processing is only done for live buffers, so + for dead buffers, the undo_list should be nil (set by Fkill_buffer), + but just to be on the safe side, we mark it here. */ + if (!BUFFER_LIVE_P (buffer)) + mark_object (BVAR (buffer, undo_list)); mark_overlay (buffer->overlays_before); mark_overlay (buffer->overlays_after); @@ -6404,7 +6563,7 @@ mark_object (Lisp_Object arg) structure allocated from the heap. */ #define CHECK_ALLOCATED() \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ { \ if (!pdumper_object_p_precise (po)) \ emacs_abort (); \ @@ -6417,19 +6576,19 @@ mark_object (Lisp_Object arg) /* Check that the object pointed to by PO is live, using predicate function LIVEP. */ -#define CHECK_LIVE(LIVEP) \ +#define CHECK_LIVE(LIVEP, MEM_TYPE) \ do { \ - if (pdumper_object_p(po)) \ + if (pdumper_object_p (po)) \ break; \ - if (!LIVEP (m, po)) \ + if (! (m->type == MEM_TYPE && LIVEP (m, po))) \ emacs_abort (); \ } while (0) /* Check both of the above conditions, for non-symbols. */ -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) \ +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) \ do { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (LIVEP); \ + CHECK_LIVE (LIVEP, MEM_TYPE); \ } while (false) /* Check both of the above conditions, for symbols. */ @@ -6438,15 +6597,14 @@ mark_object (Lisp_Object arg) if (!c_symbol_p (ptr)) \ { \ CHECK_ALLOCATED (); \ - CHECK_LIVE (live_symbol_p); \ + CHECK_LIVE (live_symbol_p, MEM_TYPE_SYMBOL); \ } \ } while (false) #else /* not GC_CHECK_MARKED_OBJECTS */ -#define CHECK_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE(LIVEP) ((void) 0) -#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE(LIVEP, MEM_TYPE) ((void) 0) +#define CHECK_ALLOCATED_AND_LIVE_SYMBOL() ((void) 0) #endif /* not GC_CHECK_MARKED_OBJECTS */ @@ -6457,7 +6615,7 @@ mark_object (Lisp_Object arg) register struct Lisp_String *ptr = XSTRING (obj); if (string_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_string_p); + CHECK_ALLOCATED_AND_LIVE (live_string_p, MEM_TYPE_STRING); set_string_marked (ptr); mark_interval_tree (ptr->u.s.intervals); #ifdef GC_CHECK_STRING_BYTES @@ -6475,36 +6633,25 @@ mark_object (Lisp_Object arg) if (vector_marked_p (ptr)) break; + enum pvec_type pvectype + = PSEUDOVECTOR_TYPE (ptr); + #ifdef GC_CHECK_MARKED_OBJECTS - if (!pdumper_object_p(po)) + if (!pdumper_object_p (po) && !SUBRP (obj) && !main_thread_p (po)) { m = mem_find (po); - if (m == MEM_NIL && !SUBRP (obj) && !main_thread_p (po)) + if (m == MEM_NIL) emacs_abort (); + if (m->type == MEM_TYPE_VECTORLIKE) + CHECK_LIVE (live_large_vector_p, MEM_TYPE_VECTORLIKE); + else + CHECK_LIVE (live_small_vector_p, MEM_TYPE_VECTOR_BLOCK); } -#endif /* GC_CHECK_MARKED_OBJECTS */ - - enum pvec_type pvectype - = PSEUDOVECTOR_TYPE (ptr); - - if (pvectype != PVEC_SUBR && - pvectype != PVEC_BUFFER && - !main_thread_p (po)) - CHECK_LIVE (live_vector_p); +#endif switch (pvectype) { case PVEC_BUFFER: -#if GC_CHECK_MARKED_OBJECTS - { - struct buffer *b; - FOR_EACH_BUFFER (b) - if (b == po) - break; - if (b == NULL) - emacs_abort (); - } -#endif /* GC_CHECK_MARKED_OBJECTS */ mark_buffer ((struct buffer *) ptr); break; @@ -6539,7 +6686,7 @@ mark_object (Lisp_Object arg) /* bool vectors in a dump are permanently "marked", since they're in the old section and don't have mark bits. If we're looking at a dumped bool vector, we should - have aborted above when we called vector_marked_p(), so + have aborted above when we called vector_marked_p, so we should never get here. */ eassert (!pdumper_object_p (ptr)); set_vector_marked (ptr); @@ -6570,7 +6717,7 @@ mark_object (Lisp_Object arg) if (symbol_marked_p (ptr)) break; CHECK_ALLOCATED_AND_LIVE_SYMBOL (); - set_symbol_marked(ptr); + set_symbol_marked (ptr); /* Attempt to catch bogus objects. */ eassert (valid_lisp_object_p (ptr->u.s.function)); mark_object (ptr->u.s.function); @@ -6611,7 +6758,7 @@ mark_object (Lisp_Object arg) struct Lisp_Cons *ptr = XCONS (obj); if (cons_marked_p (ptr)) break; - CHECK_ALLOCATED_AND_LIVE (live_cons_p); + CHECK_ALLOCATED_AND_LIVE (live_cons_p, MEM_TYPE_CONS); set_cons_marked (ptr); /* If the cdr is nil, avoid recursion for the car. */ if (NILP (ptr->u.s.u.cdr)) @@ -6629,7 +6776,7 @@ mark_object (Lisp_Object arg) } case Lisp_Float: - CHECK_ALLOCATED_AND_LIVE (live_float_p); + CHECK_ALLOCATED_AND_LIVE (live_float_p, MEM_TYPE_FLOAT); /* Do not mark floats stored in a dump image: these floats are "cold" and do not have mark bits. */ if (pdumper_object_p (XFLOAT (obj))) @@ -6983,25 +7130,17 @@ NO_INLINE /* For better stack traces */ static void sweep_buffers (void) { - struct buffer *buffer, **bprev = &all_buffers; + Lisp_Object tail, buf; gcstat.total_buffers = 0; - for (buffer = all_buffers; buffer; buffer = *bprev) - if (!vectorlike_marked_p (&buffer->header)) - { - *bprev = buffer->next; - lisp_free (buffer); - } - else - { - if (!pdumper_object_p (buffer)) - XUNMARK_VECTOR (buffer); - /* Do not use buffer_(set|get)_intervals here. */ - buffer->text->intervals = balance_intervals (buffer->text->intervals); - unchain_dead_markers (buffer); - gcstat.total_buffers++; - bprev = &buffer->next; - } + FOR_EACH_LIVE_BUFFER (tail, buf) + { + struct buffer *buffer = XBUFFER (buf); + /* Do not use buffer_(set|get)_intervals here. */ + buffer->text->intervals = balance_intervals (buffer->text->intervals); + unchain_dead_markers (buffer); + gcstat.total_buffers++; + } } /* Sweep: find all structures not marked, and free them. */ diff --git a/src/bidi.c b/src/bidi.c index 3abde7fcb09..1017bd2d523 100644 --- a/src/bidi.c +++ b/src/bidi.c @@ -109,7 +109,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ ------------------- In a nutshell, fetching the next character boils down to calling - STRING_CHAR_AND_LENGTH, passing it the address of a buffer or + string_char_and_length, passing it the address of a buffer or string position. See bidi_fetch_char. However, if the next character is "covered" by a display property of some kind, bidi_fetch_char returns the u+FFFC "object replacement character" @@ -1269,7 +1269,6 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, ptrdiff_t endpos = (string->s || STRINGP (string->lstring)) ? string->schars : ZV; struct text_pos pos; - int len; /* If we got past the last known position of display string, compute the position of the next one. That position could be at CHARPOS. */ @@ -1341,10 +1340,10 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, normal_char: if (string->s) { - if (!string->unibyte) { - ch = STRING_CHAR_AND_LENGTH (string->s + bytepos, len); + int len; + ch = string_char_and_length (string->s + bytepos, &len); *ch_len = len; } else @@ -1357,8 +1356,9 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, { if (!string->unibyte) { - ch = STRING_CHAR_AND_LENGTH (SDATA (string->lstring) + bytepos, - len); + int len; + ch = string_char_and_length (SDATA (string->lstring) + bytepos, + &len); *ch_len = len; } else @@ -1369,9 +1369,11 @@ bidi_fetch_char (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t *disp_pos, } else { - ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (bytepos), len); + int len; + ch = string_char_and_length (BYTE_POS_ADDR (bytepos), &len); *ch_len = len; } + *nchars = 1; } @@ -1550,7 +1552,7 @@ bidi_find_paragraph_start (ptrdiff_t pos, ptrdiff_t pos_byte) display string? And what if a display string covering some of the text over which we scan back includes paragraph_start_re? */ - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); if (bpc && region_cache_backward (cache_buffer, bpc, pos, &next)) { pos = next, pos_byte = CHAR_TO_BYTE (pos); @@ -1763,7 +1765,7 @@ bidi_paragraph_init (bidi_dir_t dir, struct bidi_it *bidi_it, bool no_default_p) /* FXIME: What if p is covered by a display string? See also a FIXME inside bidi_find_paragraph_start. */ - DEC_BOTH (p, pbyte); + dec_both (&p, &pbyte); prevpbyte = bidi_find_paragraph_start (p, pbyte); } pstartbyte = prevpbyte; diff --git a/src/bignum.c b/src/bignum.c index 51d90ffaefa..669df4d9ee3 100644 --- a/src/bignum.c +++ b/src/bignum.c @@ -431,3 +431,39 @@ make_bignum_str (char const *num, int base) eassert (check == 0); return make_lisp_ptr (b, Lisp_Vectorlike); } + +/* Check that X is a Lisp integer in the range LO..HI. + Return X's value as an intmax_t. */ + +intmax_t +check_integer_range (Lisp_Object x, intmax_t lo, intmax_t hi) +{ + CHECK_INTEGER (x); + intmax_t i; + if (! (integer_to_intmax (x, &i) && lo <= i && i <= hi)) + args_out_of_range_3 (x, make_int (lo), make_int (hi)); + return i; +} + +/* Check that X is a Lisp integer in the range 0..HI. + Return X's value as an uintmax_t. */ + +uintmax_t +check_uinteger_max (Lisp_Object x, uintmax_t hi) +{ + CHECK_INTEGER (x); + uintmax_t i; + if (! (integer_to_uintmax (x, &i) && i <= hi)) + args_out_of_range_3 (x, make_fixnum (0), make_uint (hi)); + return i; +} + +/* Check that X is a Lisp integer no greater than INT_MAX, + and return its value or zero, whichever is greater. */ + +int +check_int_nonnegative (Lisp_Object x) +{ + CHECK_INTEGER (x); + return NILP (Fnatnump (x)) ? 0 : check_integer_range (x, 0, INT_MAX); +} diff --git a/src/bignum.h b/src/bignum.h index 0c2541a9dc7..251a19e338a 100644 --- a/src/bignum.h +++ b/src/bignum.h @@ -22,12 +22,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #ifndef BIGNUM_H #define BIGNUM_H -#ifdef HAVE_GMP -# include <gmp.h> -#else -# include "mini-gmp.h" -#endif - +#include <gmp.h> #include "lisp.h" /* Number of data bits in a limb. */ @@ -55,7 +50,7 @@ extern void emacs_mpz_mul_2exp (mpz_t, mpz_t const, EMACS_INT) ARG_NONNULL ((1, 2)); extern void emacs_mpz_pow_ui (mpz_t, mpz_t const, unsigned long) ARG_NONNULL ((1, 2)); -extern double mpz_get_d_rounded (mpz_t const); +extern double mpz_get_d_rounded (mpz_t const) ATTRIBUTE_CONST; INLINE_HEADER_BEGIN @@ -108,7 +103,8 @@ bignum_integer (mpz_t *tmp, Lisp_Object i) if (FIXNUMP (i)) { mpz_set_intmax (*tmp, XFIXNUM (i)); - return tmp; + /* The unnecessary cast pacifies a buggy GCC 4.8.5. */ + return (mpz_t const *) tmp; } return xbignum_val (i); } diff --git a/src/buffer.c b/src/buffer.c index 92ed405b6f7..f1cb4d50414 100644 --- a/src/buffer.c +++ b/src/buffer.c @@ -51,11 +51,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "w32heap.h" /* for mmap_* */ #endif -/* First buffer in chain of all buffers (in reverse order of creation). - Threaded through ->header.next.buffer. */ - -struct buffer *all_buffers; - /* This structure holds the default values of the buffer-local variables defined with DEFVAR_PER_BUFFER, that have special slots in each buffer. The default value occupies the same slot in this structure @@ -124,6 +119,7 @@ static void free_buffer_text (struct buffer *b); static struct Lisp_Overlay * copy_overlays (struct buffer *, struct Lisp_Overlay *); static void modify_overlay (struct buffer *, ptrdiff_t, ptrdiff_t); static Lisp_Object buffer_lisp_local_variables (struct buffer *, bool); +static Lisp_Object buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym); static void CHECK_OVERLAY (Lisp_Object x) @@ -131,6 +127,23 @@ CHECK_OVERLAY (Lisp_Object x) CHECK_TYPE (OVERLAYP (x), Qoverlayp, x); } +/* Convert the position POS to an EMACS_INT that fits in a fixnum. + Yield POS's value if POS is already a fixnum, POS's marker position + if POS is a marker, and MOST_NEGATIVE_FIXNUM or + MOST_POSITIVE_FIXNUM if POS is a negative or positive bignum. + Signal an error if POS is not of the proper form. */ + +EMACS_INT +fix_position (Lisp_Object pos) +{ + if (FIXNUMP (pos)) + return XFIXNUM (pos); + if (MARKERP (pos)) + return marker_position (pos); + CHECK_TYPE (BIGNUMP (pos), Qinteger_or_marker_p, pos); + return !NILP (Fnatnump (pos)) ? MOST_POSITIVE_FIXNUM : MOST_NEGATIVE_FIXNUM; +} + /* These setters are used only in this file, so they can be private. The public setters are inline functions defined in buffer.h. */ static void @@ -1288,6 +1301,25 @@ buffer_lisp_local_variables (struct buffer *buf, bool clone) return result; } + +/* If the variable at position index OFFSET in buffer BUF has a + buffer-local value, return (name . value). If SYM is non-nil, + it replaces name. */ + +static Lisp_Object +buffer_local_variables_1 (struct buffer *buf, int offset, Lisp_Object sym) +{ + int idx = PER_BUFFER_IDX (offset); + if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) + && SYMBOLP (PER_BUFFER_SYMBOL (offset))) + { + sym = NILP (sym) ? PER_BUFFER_SYMBOL (offset) : sym; + Lisp_Object val = per_buffer_value (buf, offset); + return EQ (val, Qunbound) ? sym : Fcons (sym, val); + } + return Qnil; +} + DEFUN ("buffer-local-variables", Fbuffer_local_variables, Sbuffer_local_variables, 0, 1, 0, doc: /* Return an alist of variables that are buffer-local in BUFFER. @@ -1299,25 +1331,25 @@ No argument or nil as argument means use current buffer as BUFFER. */) { struct buffer *buf = decode_buffer (buffer); Lisp_Object result = buffer_lisp_local_variables (buf, 0); + Lisp_Object tem; /* Add on all the variables stored in special slots. */ { - int offset, idx; + int offset; FOR_EACH_PER_BUFFER_OBJECT_AT (offset) { - idx = PER_BUFFER_IDX (offset); - if ((idx == -1 || PER_BUFFER_VALUE_P (buf, idx)) - && SYMBOLP (PER_BUFFER_SYMBOL (offset))) - { - Lisp_Object sym = PER_BUFFER_SYMBOL (offset); - Lisp_Object val = per_buffer_value (buf, offset); - result = Fcons (EQ (val, Qunbound) ? sym : Fcons (sym, val), - result); - } + tem = buffer_local_variables_1 (buf, offset, Qnil); + if (!NILP (tem)) + result = Fcons (tem, result); } } + tem = buffer_local_variables_1 (buf, PER_BUFFER_VAR_OFFSET (undo_list), + intern ("buffer-undo-list")); + if (!NILP (tem)) + result = Fcons (tem, result); + return result; } @@ -1769,15 +1801,11 @@ cleaning up all windows currently displaying the buffer to be killed. */) ask questions or their hooks get errors. */ if (!b->base_buffer && b->indirections > 0) { - struct buffer *other; + Lisp_Object tail, other; - FOR_EACH_BUFFER (other) - if (other->base_buffer == b) - { - Lisp_Object buf; - XSETBUFFER (buf, other); - Fkill_buffer (buf); - } + FOR_EACH_LIVE_BUFFER (tail, other) + if (XBUFFER (other)->base_buffer == b) + Fkill_buffer (other); /* Exit if we now have killed the base buffer (Bug#11665). */ if (!BUFFER_LIVE_P (b)) @@ -1832,6 +1860,9 @@ cleaning up all windows currently displaying the buffer to be killed. */) tem = Vinhibit_quit; Vinhibit_quit = Qt; + /* Once the buffer is removed from Vbuffer_alist, its undo_list field is + not traced by the GC in the same way. So set it to nil early. */ + bset_undo_list (b, Qnil); /* Remove the buffer from the list of all buffers. */ Vbuffer_alist = Fdelq (Frassq (buffer, Vbuffer_alist), Vbuffer_alist); /* If replace_buffer_in_windows didn't do its job fix that now. */ @@ -1946,7 +1977,6 @@ cleaning up all windows currently displaying the buffer to be killed. */) } bset_width_table (b, Qnil); unblock_input (); - bset_undo_list (b, Qnil); /* Run buffer-list-update-hook. */ if (!NILP (Vrun_hooks) && !b->inhibit_buffer_hooks) @@ -2257,19 +2287,20 @@ so the buffer is truly empty after this. */) } void -validate_region (register Lisp_Object *b, register Lisp_Object *e) +validate_region (Lisp_Object *b, Lisp_Object *e) { - CHECK_FIXNUM_COERCE_MARKER (*b); - CHECK_FIXNUM_COERCE_MARKER (*e); + EMACS_INT beg = fix_position (*b), end = fix_position (*e); - if (XFIXNUM (*b) > XFIXNUM (*e)) + if (end < beg) { - Lisp_Object tem; - tem = *b; *b = *e; *e = tem; + EMACS_INT tem = beg; beg = end; end = tem; } - if (! (BEGV <= XFIXNUM (*b) && XFIXNUM (*e) <= ZV)) + if (! (BEGV <= beg && end <= ZV)) args_out_of_range_3 (Fcurrent_buffer (), *b, *e); + + *b = make_fixnum (beg); + *e = make_fixnum (end); } /* Advance BYTE_POS up to a character boundary @@ -2297,7 +2328,7 @@ advance_to_char_boundary (ptrdiff_t byte_pos) c = FETCH_BYTE (byte_pos); } while (! CHAR_HEAD_P (c) && byte_pos > BEG); - INC_POS (byte_pos); + byte_pos += next_char_len (byte_pos); if (byte_pos < orig_byte_pos) byte_pos = orig_byte_pos; /* If C is a constituent of a multibyte sequence, BYTE_POS was @@ -2333,10 +2364,10 @@ results, see Info node `(elisp)Swapping Text'. */) error ("Cannot swap indirect buffers's text"); { /* This is probably harder to make work. */ - struct buffer *other; - FOR_EACH_BUFFER (other) - if (other->base_buffer == other_buffer - || other->base_buffer == current_buffer) + Lisp_Object tail, other; + FOR_EACH_LIVE_BUFFER (tail, other) + if (XBUFFER (other)->base_buffer == other_buffer + || XBUFFER (other)->base_buffer == current_buffer) error ("One of the buffers to swap has indirect buffers"); } @@ -2484,7 +2515,7 @@ current buffer is cleared. */) (Lisp_Object flag) { struct Lisp_Marker *tail, *markers; - struct buffer *other; + Lisp_Object btail, other; ptrdiff_t begv, zv; bool narrowed = (BEG != BEGV || Z != ZV); bool modified_p = !NILP (Fbuffer_modified_p (Qnil)); @@ -2541,8 +2572,6 @@ current buffer is cleared. */) p = BEG_ADDR; while (1) { - int c, bytes; - if (pos == stop) { if (pos == Z) @@ -2554,7 +2583,7 @@ current buffer is cleared. */) p++, pos++; else if (CHAR_BYTE8_HEAD_P (*p)) { - c = STRING_CHAR_AND_LENGTH (p, bytes); + int bytes, c = string_char_and_length (p, &bytes); /* Delete all bytes for this 8-bit character but the last one, and change the last one to the character code. */ @@ -2571,7 +2600,7 @@ current buffer is cleared. */) } else { - bytes = BYTES_BY_CHAR_HEAD (*p); + int bytes = BYTES_BY_CHAR_HEAD (*p); p += bytes, pos += bytes; } } @@ -2625,8 +2654,7 @@ current buffer is cleared. */) if (ASCII_CHAR_P (*p)) p++, pos++; else if (EQ (flag, Qt) - && ! CHAR_BYTE8_HEAD_P (*p) - && (bytes = MULTIBYTE_LENGTH (p, pend)) > 0) + && 0 < (bytes = multibyte_length (p, pend, true, false))) p += bytes, pos += bytes; else { @@ -2737,13 +2765,16 @@ current buffer is cleared. */) /* Copy this buffer's new multibyte status into all of its indirect buffers. */ - FOR_EACH_BUFFER (other) - if (other->base_buffer == current_buffer && BUFFER_LIVE_P (other)) - { - BVAR (other, enable_multibyte_characters) - = BVAR (current_buffer, enable_multibyte_characters); - other->prevent_redisplay_optimizations_p = 1; - } + FOR_EACH_LIVE_BUFFER (btail, other) + { + struct buffer *o = XBUFFER (other); + if (o->base_buffer == current_buffer && BUFFER_LIVE_P (o)) + { + BVAR (o, enable_multibyte_characters) + = BVAR (current_buffer, enable_multibyte_characters); + o->prevent_redisplay_optimizations_p = true; + } + } /* Restore the modifiedness of the buffer. */ if (!modified_p && !NILP (Fbuffer_modified_p (Qnil))) @@ -5309,8 +5340,6 @@ init_buffer_once (void) Vbuffer_alist = Qnil; current_buffer = 0; pdumper_remember_lv_ptr_raw (¤t_buffer, Lisp_Vectorlike); - all_buffers = 0; - pdumper_remember_lv_ptr_raw (&all_buffers, Lisp_Vectorlike); QSFundamental = build_pure_c_string ("Fundamental"); @@ -5341,7 +5370,7 @@ init_buffer (void) #ifdef USE_MMAP_FOR_BUFFERS if (dumped_with_unexec_p ()) { - struct buffer *b; + Lisp_Object tail, buffer; #ifndef WINDOWSNT /* These must be reset in the dumped Emacs, to avoid stale @@ -5363,23 +5392,13 @@ init_buffer (void) " *code-conversion-work*". They are created by init_buffer_once and init_window_once (which are not called in the dumped Emacs), and by the first call to coding.c routines. */ - FOR_EACH_BUFFER (b) + FOR_EACH_LIVE_BUFFER (tail, buffer) { + struct buffer *b = XBUFFER (buffer); b->text->beg = NULL; enlarge_buffer_text (b, 0); } } - else - { - struct buffer *b; - - /* Only buffers with allocated buffer text should be present at - this point in temacs. */ - FOR_EACH_BUFFER (b) - { - eassert (b->text->beg != NULL); - } - } #endif /* USE_MMAP_FOR_BUFFERS */ AUTO_STRING (scratch, "*scratch*"); @@ -6247,6 +6266,9 @@ Values are interpreted as follows: t use the cursor specified for the frame nil don't display a cursor box display a filled box cursor + (box . SIZE) display a filled box cursor, but make it + hollow if cursor is under masked image larger than + SIZE pixels in either dimension. hollow display a hollow box cursor bar display a vertical bar cursor with default width (bar . WIDTH) display a vertical bar cursor with width WIDTH diff --git a/src/buffer.h b/src/buffer.h index fd05fdd37de..3da49414bb8 100644 --- a/src/buffer.h +++ b/src/buffer.h @@ -570,9 +570,6 @@ struct buffer In an indirect buffer, this is the own_text field of another buffer. */ struct buffer_text *text; - /* Next buffer, in chain of all buffers, including killed ones. */ - struct buffer *next; - /* Char position of point in buffer. */ ptrdiff_t pt; @@ -1104,15 +1101,6 @@ BUFFER_CHECK_INDIRECTION (struct buffer *b) } } -/* Chain of all buffers, including killed ones. */ - -extern struct buffer *all_buffers; - -/* Used to iterate over the chain above. */ - -#define FOR_EACH_BUFFER(b) \ - for ((b) = all_buffers; (b); (b) = (b)->next) - /* This structure holds the default values of the buffer-local variables that have special slots in each buffer. The default value occupies the same slot in this structure @@ -1150,6 +1138,8 @@ extern Lisp_Object interval_insert_behind_hooks; extern Lisp_Object interval_insert_in_front_hooks; +extern EMACS_INT fix_position (Lisp_Object); +#define CHECK_FIXNUM_COERCE_MARKER(x) ((x) = make_fixnum (fix_position (x))) extern void delete_all_overlays (struct buffer *); extern void reset_buffer (struct buffer *); extern void compact_buffer (struct buffer *); @@ -1533,6 +1523,146 @@ lowercasep (int c) return !uppercasep (c) && upcase (c) != c; } +/* Return a non-outlandish value for the tab width. */ + +INLINE int +sanitize_tab_width (Lisp_Object width) +{ + return (FIXNUMP (width) && 0 < XFIXNUM (width) && XFIXNUM (width) <= 1000 + ? XFIXNUM (width) : 8); +} + +INLINE int +SANE_TAB_WIDTH (struct buffer *buf) +{ + return sanitize_tab_width (BVAR (buf, tab_width)); +} + +/* Return a non-outlandish value for a character width. */ + +INLINE int +sanitize_char_width (EMACS_INT width) +{ + return 0 <= width && width <= 1000 ? width : 1000; +} + +/* Return the width of character C. The width is measured by how many + columns C will occupy on the screen when displayed in the current + buffer. The name CHARACTER_WIDTH avoids a collision with <limits.h> + CHAR_WIDTH. */ + +INLINE int +CHARACTER_WIDTH (int c) +{ + return (0x20 <= c && c < 0x7f ? 1 + : 0x7f < c ? (sanitize_char_width + (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c)))) + : c == '\t' ? SANE_TAB_WIDTH (current_buffer) + : c == '\n' ? 0 + : !NILP (BVAR (current_buffer, ctl_arrow)) ? 2 : 4); +} + + +/* Like fetch_string_char_advance, but fetch character from the current + buffer. */ + +INLINE int +fetch_char_advance (ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t c = *charidx, b = *byteidx; + c++; + unsigned char *chp = BYTE_POS_ADDR (b); + if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = *chp; + b++; + } + *charidx = c; + *byteidx = b; + return output; +} + + +/* Like fetch_char_advance, but assumes the current buffer is multibyte. */ + +INLINE int +fetch_char_advance_no_check (ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t c = *charidx, b = *byteidx; + c++; + unsigned char *chp = BYTE_POS_ADDR (b); + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + *charidx = c; + *byteidx = b; + return output; +} + +/* Return the number of bytes in the multibyte character in BUF + that starts at position POS_BYTE. This relies on the fact that + *GPT_ADDR and *Z_ADDR are always accessible and the values are + '\0'. No range checking of POS_BYTE. */ + +INLINE int +buf_next_char_len (struct buffer *buf, ptrdiff_t pos_byte) +{ + unsigned char *chp = BUF_BYTE_ADDRESS (buf, pos_byte); + return BYTES_BY_CHAR_HEAD (*chp); +} + +INLINE int +next_char_len (ptrdiff_t pos_byte) +{ + return buf_next_char_len (current_buffer, pos_byte); +} + +/* Return the number of bytes in the multibyte character in BUF just + before POS_BYTE. No range checking of POS_BYTE. */ + +INLINE int +buf_prev_char_len (struct buffer *buf, ptrdiff_t pos_byte) +{ + unsigned char *chp + = (BUF_BEG_ADDR (buf) + pos_byte - BEG_BYTE + + (pos_byte <= BUF_GPT_BYTE (buf) ? 0 : BUF_GAP_SIZE (buf))); + return raw_prev_char_len (chp); +} + +INLINE int +prev_char_len (ptrdiff_t pos_byte) +{ + return buf_prev_char_len (current_buffer, pos_byte); +} + +/* Increment both *CHARPOS and *BYTEPOS, each in the appropriate way. */ + +INLINE void +inc_both (ptrdiff_t *charpos, ptrdiff_t *bytepos) +{ + (*charpos)++; + (*bytepos) += (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? next_char_len (*bytepos) : 1); +} + +/* Decrement both *CHARPOS and *BYTEPOS, each in the appropriate way. */ + +INLINE void +dec_both (ptrdiff_t *charpos, ptrdiff_t *bytepos) +{ + (*charpos)--; + (*bytepos) -= (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? prev_char_len (*bytepos) : 1); +} + INLINE_HEADER_END #endif /* EMACS_BUFFER_H */ diff --git a/src/bytecode.c b/src/bytecode.c index 9e75c9012e0..5ac30aa1010 100644 --- a/src/bytecode.c +++ b/src/bytecode.c @@ -220,10 +220,10 @@ DEFINE (Bdup, 0211) \ DEFINE (Bsave_excursion, 0212) \ DEFINE (Bsave_window_excursion, 0213) /* Obsolete since Emacs-24.1. */ \ DEFINE (Bsave_restriction, 0214) \ -DEFINE (Bcatch, 0215) \ +DEFINE (Bcatch, 0215) /* Obsolete since Emacs-25. */ \ \ DEFINE (Bunwind_protect, 0216) \ -DEFINE (Bcondition_case, 0217) \ +DEFINE (Bcondition_case, 0217) /* Obsolete since Emacs-25. */ \ DEFINE (Btemp_output_buffer_setup, 0220) /* Obsolete since Emacs-24.1. */ \ DEFINE (Btemp_output_buffer_show, 0221) /* Obsolete since Emacs-24.1. */ \ \ @@ -319,6 +319,19 @@ the third, MAXDEPTH, the maximum stack depth used in this function. If the third argument is incorrect, Emacs may crash. */) (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth) { + if (! (STRINGP (bytestr) && VECTORP (vector) && FIXNATP (maxdepth))) + error ("Invalid byte-code"); + + if (STRING_MULTIBYTE (bytestr)) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytestr = Fstring_as_unibyte (bytestr); + } + return exec_byte_code (bytestr, vector, maxdepth, Qnil, 0, NULL); } @@ -344,21 +357,10 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, int volatile this_op = 0; #endif - CHECK_STRING (bytestr); - CHECK_VECTOR (vector); - CHECK_FIXNAT (maxdepth); + eassert (!STRING_MULTIBYTE (bytestr)); ptrdiff_t const_length = ASIZE (vector); - - if (STRING_MULTIBYTE (bytestr)) - /* BYTESTR must have been produced by Emacs 20.2 or the earlier - because they produced a raw 8-bit string for byte-code and now - such a byte-code string is loaded as multibyte while raw 8-bit - characters converted to multibyte form. Thus, now we must - convert them back to the originally intended unibyte form. */ - bytestr = Fstring_as_unibyte (bytestr); - - ptrdiff_t bytestr_length = SBYTES (bytestr); + ptrdiff_t bytestr_length = SCHARS (bytestr); Lisp_Object *vectorp = XVECTOR (vector)->contents; unsigned char quitcounter = 1; @@ -763,7 +765,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, save_restriction_save ()); NEXT; - CASE (Bcatch): /* Obsolete since 24.4. */ + CASE (Bcatch): /* Obsolete since 25. */ { Lisp_Object v1 = POP; TOP = internal_catch (TOP, eval_sub, v1); @@ -807,7 +809,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, NEXT; } - CASE (Bcondition_case): /* Obsolete since 24.4. */ + CASE (Bcondition_case): /* Obsolete since 25. */ { Lisp_Object handlers = POP, body = POP; TOP = internal_lisp_condition_case (TOP, body, handlers); @@ -1172,7 +1174,7 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth, CHECK_CHARACTER (TOP); int c = XFIXNAT (TOP); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); XSETFASTINT (TOP, syntax_code_spec[SYNTAX (c)]); } NEXT; diff --git a/src/callproc.c b/src/callproc.c index 8883415f3f5..65c858393a9 100644 --- a/src/callproc.c +++ b/src/callproc.c @@ -1099,7 +1099,17 @@ usage: (call-process-region START END PROGRAM &optional DELETE BUFFER DISPLAY &r } if (nargs > 3 && !NILP (args[3])) - Fdelete_region (start, end); + { + if (NILP (start)) + { + /* No need to save restrictions since we delete everything + anyway. */ + Fwiden (); + del_range (BEG, Z); + } + else + Fdelete_region (start, end); + } if (nargs > 3) { diff --git a/src/casefiddle.c b/src/casefiddle.c index 1945aa15e71..debd2412238 100644 --- a/src/casefiddle.c +++ b/src/casefiddle.c @@ -220,6 +220,13 @@ case_character (struct casing_str_buf *buf, struct casing_context *ctx, return changed; } +/* If C is not ASCII, make it unibyte. */ +static inline int +make_char_unibyte (int c) +{ + return ASCII_CHAR_P (c) ? c : CHAR_TO_BYTE8 (c); +} + static Lisp_Object do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) { @@ -229,7 +236,7 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) /* If the character has higher bits set above the flags, return it unchanged. It is not a real character. */ - if (UNSIGNED_CMP (ch, >, flagbits)) + if (! (0 <= ch && ch <= flagbits)) return obj; int flags = ch & flagbits; @@ -243,13 +250,13 @@ do_casify_natnum (struct casing_context *ctx, Lisp_Object obj) || !NILP (BVAR (current_buffer, enable_multibyte_characters))); if (! multibyte) - MAKE_CHAR_MULTIBYTE (ch); + ch = make_char_multibyte (ch); int cased = case_single_character (ctx, ch); if (cased == ch) return obj; if (! multibyte) - MAKE_CHAR_UNIBYTE (cased); + cased = make_char_unibyte (cased); return make_fixed_natnum (cased | flags); } @@ -278,7 +285,7 @@ do_casify_multibyte_string (struct casing_context *ctx, Lisp_Object obj) { if (dst_end - o < sizeof (struct casing_str_buf)) string_overflow (); - int ch = STRING_CHAR_ADVANCE (src); + int ch = string_char_advance (&src); case_character ((struct casing_str_buf *) o, ctx, ch, size > 1 ? src : NULL); n += ((struct casing_str_buf *) o)->len_chars; @@ -299,15 +306,14 @@ do_casify_unibyte_string (struct casing_context *ctx, Lisp_Object obj) obj = Fcopy_sequence (obj); for (i = 0; i < size; i++) { - ch = SREF (obj, i); - MAKE_CHAR_MULTIBYTE (ch); + ch = make_char_multibyte (SREF (obj, i)); cased = case_single_character (ctx, ch); if (ch == cased) continue; - MAKE_CHAR_UNIBYTE (cased); + cased = make_char_unibyte (cased); /* If the char can't be converted to a valid byte, just don't change it. */ - if (cased >= 0 && cased < 256) + if (SINGLE_BYTE_CHAR_P (cased)) SSET (obj, i, cased); } return obj; @@ -397,9 +403,7 @@ do_casify_unibyte_region (struct casing_context *ctx, for (ptrdiff_t pos = *startp; pos < end; ++pos) { - int ch = FETCH_BYTE (pos); - MAKE_CHAR_MULTIBYTE (ch); - + int ch = make_char_multibyte (FETCH_BYTE (pos)); int cased = case_single_character (ctx, ch); if (cased == ch) continue; @@ -408,8 +412,7 @@ do_casify_unibyte_region (struct casing_context *ctx, if (first < 0) first = pos; - MAKE_CHAR_UNIBYTE (cased); - FETCH_BYTE (pos) = cased; + FETCH_BYTE (pos) = make_char_unibyte (cased); } *startp = first; @@ -433,8 +436,7 @@ do_casify_multibyte_region (struct casing_context *ctx, for (; size; --size) { - int len; - int ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (pos_byte), len); + int len, ch = string_char_and_length (BYTE_POS_ADDR (pos_byte), &len); struct casing_str_buf buf; if (!case_character (&buf, ctx, ch, size > 1 ? BYTE_POS_ADDR (pos_byte + len) : NULL)) diff --git a/src/ccl.c b/src/ccl.c index ac44dc1f608..ef059ffff25 100644 --- a/src/ccl.c +++ b/src/ccl.c @@ -855,6 +855,13 @@ struct ccl_prog_stack /* For the moment, we only support depth 256 of stack. */ static struct ccl_prog_stack ccl_prog_stack_struct[256]; +/* Return a translation table of id number ID. */ +static inline Lisp_Object +GET_TRANSLATION_TABLE (int id) +{ + return XCDR (XVECTOR (Vtranslation_table_vector)->contents[id]); +} + void ccl_driver (struct ccl_program *ccl, int *source, int *destination, int src_size, int dst_size, Lisp_Object charset_list) { @@ -2101,7 +2108,7 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY source[j++] = *p++; else while (j < CCL_EXECUTE_BUF_SIZE && p < endp) - source[j++] = STRING_CHAR_ADVANCE (p); + source[j++] = string_char_advance (&p); consumed_chars += j; consumed_bytes = p - SDATA (str); @@ -2126,7 +2133,7 @@ usage: (ccl-execute-on-string CCL-PROGRAM STATUS STRING &optional CONTINUE UNIBY if (NILP (unibyte_p)) { for (j = 0; j < ccl.produced; j++) - CHAR_STRING_ADVANCE (destination[j], outp); + outp += CHAR_STRING (destination[j], outp); } else { diff --git a/src/character.c b/src/character.c index 5d419a2e836..4902e564b1d 100644 --- a/src/character.c +++ b/src/character.c @@ -141,58 +141,6 @@ char_string (unsigned int c, unsigned char *p) } -/* Return a character whose multibyte form is at P. If LEN is not - NULL, it must be a pointer to integer. In that case, set *LEN to - the byte length of the multibyte form. If ADVANCED is not NULL, it - must be a pointer to unsigned char. In that case, set *ADVANCED to - the ending address (i.e., the starting address of the next - character) of the multibyte form. */ - -int -string_char (const unsigned char *p, const unsigned char **advanced, int *len) -{ - int c; - const unsigned char *saved_p = p; - - if (*p < 0x80 || ! (*p & 0x20) || ! (*p & 0x10)) - { - /* 1-, 2-, and 3-byte sequences can be handled by the macro. */ - c = STRING_CHAR_ADVANCE (p); - } - else if (! (*p & 0x08)) - { - /* A 4-byte sequence of this form: - 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx */ - c = ((((p)[0] & 0x7) << 18) - | (((p)[1] & 0x3F) << 12) - | (((p)[2] & 0x3F) << 6) - | ((p)[3] & 0x3F)); - p += 4; - } - else - { - /* A 5-byte sequence of this form: - - 111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx - - Note that the top 4 `x's are always 0, so shifting p[1] can - never exceed the maximum valid character codepoint. */ - c = (/* (((p)[0] & 0x3) << 24) ... always 0, so no need to shift. */ - (((p)[1] & 0x3F) << 18) - | (((p)[2] & 0x3F) << 12) - | (((p)[3] & 0x3F) << 6) - | ((p)[4] & 0x3F)); - p += 5; - } - - if (len) - *len = p - saved_p; - if (advanced) - *advanced = p; - return c; -} - - /* Translate character C by translation table TABLE. If no translation is found in TABLE, return the untranslated character. If TABLE is a list, elements are char tables. In that case, recursively translate C by all the @@ -248,8 +196,7 @@ DEFUN ("unibyte-char-to-multibyte", Funibyte_char_to_multibyte, c = XFIXNAT (ch); if (c >= 0x100) error ("Not a unibyte character: %d", c); - MAKE_CHAR_MULTIBYTE (c); - return make_fixnum (c); + return make_fixnum (make_char_multibyte (c)); } DEFUN ("multibyte-char-to-unibyte", Fmultibyte_char_to_unibyte, @@ -340,8 +287,7 @@ c_string_width (const unsigned char *str, ptrdiff_t len, int precision, while (i_byte < len) { - int bytes; - int c = STRING_CHAR_AND_LENGTH (str + i_byte, bytes); + int bytes, c = string_char_and_length (str + i_byte, &bytes); ptrdiff_t thiswidth = char_width (c, dp); if (0 < precision && precision - width < thiswidth) @@ -418,7 +364,7 @@ lisp_string_width (Lisp_Object string, ptrdiff_t precision, if (multibyte) { int cbytes; - c = STRING_CHAR_AND_LENGTH (str + i_byte, cbytes); + c = string_char_and_length (str + i_byte, &cbytes); bytes = cbytes; } else @@ -495,7 +441,7 @@ multibyte_chars_in_text (const unsigned char *ptr, ptrdiff_t nbytes) while (ptr < endp) { - int len = MULTIBYTE_LENGTH (ptr, endp); + int len = multibyte_length (ptr, endp, true, true); if (len == 0) emacs_abort (); @@ -517,16 +463,15 @@ parse_str_as_multibyte (const unsigned char *str, ptrdiff_t len, ptrdiff_t *nchars, ptrdiff_t *nbytes) { const unsigned char *endp = str + len; - int n; ptrdiff_t chars = 0, bytes = 0; if (len >= MAX_MULTIBYTE_LENGTH) { - const unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; + const unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); while (str < adjusted_endp) { - if (! CHAR_BYTE8_HEAD_P (*str) - && (n = MULTIBYTE_LENGTH_NO_CHECK (str)) > 0) + int n = multibyte_length (str, NULL, false, false); + if (0 < n) str += n, bytes += n; else str++, bytes += 2; @@ -535,8 +480,8 @@ parse_str_as_multibyte (const unsigned char *str, ptrdiff_t len, } while (str < endp) { - if (! CHAR_BYTE8_HEAD_P (*str) - && (n = MULTIBYTE_LENGTH (str, endp)) > 0) + int n = multibyte_length (str, endp, true, false); + if (0 < n) str += n, bytes += n; else str++, bytes += 2; @@ -563,20 +508,25 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, unsigned char *p = str, *endp = str + nbytes; unsigned char *to; ptrdiff_t chars = 0; - int n; if (nbytes >= MAX_MULTIBYTE_LENGTH) { - unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; - while (p < adjusted_endp - && ! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH_NO_CHECK (p)) > 0) - p += n, chars++; + unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); + while (p < adjusted_endp) + { + int n = multibyte_length (p, NULL, false, false); + if (n <= 0) + break; + p += n, chars++; + } + } + while (true) + { + int n = multibyte_length (p, endp, true, false); + if (n <= 0) + break; + p += n, chars++; } - while (p < endp - && ! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH (p, endp)) > 0) - p += n, chars++; if (nchars) *nchars = chars; if (p == endp) @@ -590,11 +540,11 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, if (nbytes >= MAX_MULTIBYTE_LENGTH) { - unsigned char *adjusted_endp = endp - MAX_MULTIBYTE_LENGTH; + unsigned char *adjusted_endp = endp - (MAX_MULTIBYTE_LENGTH - 1); while (p < adjusted_endp) { - if (! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH_NO_CHECK (p)) > 0) + int n = multibyte_length (p, NULL, false, false); + if (0 < n) { while (n--) *to++ = *p++; @@ -610,8 +560,8 @@ str_as_multibyte (unsigned char *str, ptrdiff_t len, ptrdiff_t nbytes, } while (p < endp) { - if (! CHAR_BYTE8_HEAD_P (*p) - && (n = MULTIBYTE_LENGTH (p, endp)) > 0) + int n = multibyte_length (p, endp, true, false); + if (0 < n) { while (n--) *to++ = *p++; @@ -706,7 +656,7 @@ str_as_unibyte (unsigned char *str, ptrdiff_t bytes) len = BYTES_BY_CHAR_HEAD (c); if (CHAR_BYTE8_HEAD_P (c)) { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); *to++ = CHAR_TO_BYTE8 (c); } else @@ -730,7 +680,7 @@ str_to_unibyte (const unsigned char *src, unsigned char *dst, ptrdiff_t chars) for (i = 0; i < chars; i++) { - int c = STRING_CHAR_ADVANCE (src); + int c = string_char_advance (&src); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); @@ -823,7 +773,7 @@ string_escape_byte8 (Lisp_Object string) if (CHAR_BYTE8_HEAD_P (c)) { - c = STRING_CHAR_ADVANCE (src); + c = string_char_advance (&src); c = CHAR_TO_BYTE8 (c); dst += sprintf ((char *) dst, "\\%03o", c + 0u); } @@ -849,24 +799,22 @@ Concatenate all the argument characters and make the result a string. usage: (string &rest CHARACTERS) */) (ptrdiff_t n, Lisp_Object *args) { - ptrdiff_t i; - int c; - unsigned char *buf, *p; - Lisp_Object str; - USE_SAFE_ALLOCA; - - SAFE_NALLOCA (buf, MAX_MULTIBYTE_LENGTH, n); - p = buf; - - for (i = 0; i < n; i++) + ptrdiff_t nbytes = 0; + for (ptrdiff_t i = 0; i < n; i++) { CHECK_CHARACTER (args[i]); - c = XFIXNUM (args[i]); + nbytes += CHAR_BYTES (XFIXNUM (args[i])); + } + if (nbytes == n) + return Funibyte_string (n, args); + Lisp_Object str = make_uninit_multibyte_string (n, nbytes); + unsigned char *p = SDATA (str); + for (ptrdiff_t i = 0; i < n; i++) + { + eassume (CHARACTERP (args[i])); + int c = XFIXNUM (args[i]); p += CHAR_STRING (c, p); } - - str = make_string_from_bytes ((char *) buf, n, p - buf); - SAFE_FREE (); return str; } @@ -875,20 +823,10 @@ DEFUN ("unibyte-string", Funibyte_string, Sunibyte_string, 0, MANY, 0, usage: (unibyte-string &rest BYTES) */) (ptrdiff_t n, Lisp_Object *args) { - ptrdiff_t i; - Lisp_Object str; - USE_SAFE_ALLOCA; - unsigned char *buf = SAFE_ALLOCA (n); - unsigned char *p = buf; - - for (i = 0; i < n; i++) - { - CHECK_RANGED_INTEGER (args[i], 0, 255); - *p++ = XFIXNUM (args[i]); - } - - str = make_string_from_bytes ((char *) buf, n, p - buf); - SAFE_FREE (); + Lisp_Object str = make_uninit_string (n); + unsigned char *p = SDATA (str); + for (ptrdiff_t i = 0; i < n; i++) + *p++ = check_integer_range (args[i], 0, 255); return str; } @@ -931,10 +869,10 @@ character is not ASCII nor 8-bit character, an error is signaled. */) } else { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEGV || XFIXNUM (position) >= ZV) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNAT (position); + pos = fixed_pos; p = CHAR_POS_ADDR (pos); } if (NILP (BVAR (current_buffer, enable_multibyte_characters))) diff --git a/src/character.h b/src/character.h index 3642a540448..af5023f77cc 100644 --- a/src/character.h +++ b/src/character.h @@ -31,35 +31,39 @@ INLINE_HEADER_BEGIN /* character code 1st byte byte sequence -------------- -------- ------------- 0-7F 00..7F 0xxxxxxx - 80-7FF C2..DF 110xxxxx 10xxxxxx - 800-FFFF E0..EF 1110xxxx 10xxxxxx 10xxxxxx - 10000-1FFFFF F0..F7 11110xxx 10xxxxxx 10xxxxxx 10xxxxxx - 200000-3FFF7F F8 11111000 1000xxxx 10xxxxxx 10xxxxxx 10xxxxxx + 80-7FF C2..DF 110yyyyx 10xxxxxx + 800-FFFF E0..EF 1110yyyy 10yxxxxx 10xxxxxx + 10000-1FFFFF F0..F7 11110yyy 10yyxxxx 10xxxxxx 10xxxxxx + 200000-3FFF7F F8 11111000 1000yxxx 10xxxxxx 10xxxxxx 10xxxxxx 3FFF80-3FFFFF C0..C1 1100000x 10xxxxxx (for eight-bit-char) 400000-... invalid invalid 1st byte 80..BF 10xxxxxx - F9..FF 11111xxx (xxx != 000) + F9..FF 11111yyy + + In each bit pattern, 'x' and 'y' each represent a single bit of the + character code payload, and least one 'y' must be a 1 bit. + In the 5-byte sequence, the 22-bit payload cannot exceed 3FFF7F. */ /* Maximum character code ((1 << CHARACTERBITS) - 1). */ -#define MAX_CHAR 0x3FFFFF +enum { MAX_CHAR = 0x3FFFFF }; /* Maximum Unicode character code. */ -#define MAX_UNICODE_CHAR 0x10FFFF +enum { MAX_UNICODE_CHAR = 0x10FFFF }; /* Maximum N-byte character codes. */ -#define MAX_1_BYTE_CHAR 0x7F -#define MAX_2_BYTE_CHAR 0x7FF -#define MAX_3_BYTE_CHAR 0xFFFF -#define MAX_4_BYTE_CHAR 0x1FFFFF -#define MAX_5_BYTE_CHAR 0x3FFF7F +enum { MAX_1_BYTE_CHAR = 0x7F }; +enum { MAX_2_BYTE_CHAR = 0x7FF }; +enum { MAX_3_BYTE_CHAR = 0xFFFF }; +enum { MAX_4_BYTE_CHAR = 0x1FFFFF }; +enum { MAX_5_BYTE_CHAR = 0x3FFF7F }; /* Minimum leading code of multibyte characters. */ -#define MIN_MULTIBYTE_LEADING_CODE 0xC0 +enum { MIN_MULTIBYTE_LEADING_CODE = 0xC0 }; /* Maximum leading code of multibyte characters. Note: this must be updated if we ever increase MAX_CHAR above. */ -#define MAX_MULTIBYTE_LEADING_CODE 0xF8 +enum { MAX_MULTIBYTE_LEADING_CODE = 0xF8 }; /* Unicode character values. */ enum @@ -80,533 +84,432 @@ enum OBJECT_REPLACEMENT_CHARACTER = 0xFFFC, }; +extern int char_string (unsigned, unsigned char *); + /* UTF-8 encodings. Use \x escapes, so they are portable to pre-C11 compilers and can be concatenated with ordinary string literals. */ #define uLSQM "\xE2\x80\x98" /* U+2018 LEFT SINGLE QUOTATION MARK */ #define uRSQM "\xE2\x80\x99" /* U+2019 RIGHT SINGLE QUOTATION MARK */ -/* Nonzero iff C is a character that corresponds to a raw 8-bit +/* True iff C is a character of code less than 0x100. */ +INLINE bool +SINGLE_BYTE_CHAR_P (intmax_t c) +{ + return 0 <= c && c < 0x100; +} + +/* True iff C is a character that corresponds to a raw 8-bit byte. */ -#define CHAR_BYTE8_P(c) ((c) > MAX_5_BYTE_CHAR) +INLINE bool +CHAR_BYTE8_P (int c) +{ + return MAX_5_BYTE_CHAR < c; +} /* Return the character code for raw 8-bit byte BYTE. */ -#define BYTE8_TO_CHAR(byte) ((byte) + 0x3FFF00) +INLINE int +BYTE8_TO_CHAR (int byte) +{ + return byte + 0x3FFF00; +} -#define UNIBYTE_TO_CHAR(byte) \ - (ASCII_CHAR_P (byte) ? (byte) : BYTE8_TO_CHAR (byte)) +INLINE int +UNIBYTE_TO_CHAR (int byte) +{ + return ASCII_CHAR_P (byte) ? byte : BYTE8_TO_CHAR (byte); +} /* Return the raw 8-bit byte for character C. */ -#define CHAR_TO_BYTE8(c) (CHAR_BYTE8_P (c) ? (c) - 0x3FFF00 : (c & 0xFF)) +INLINE int +CHAR_TO_BYTE8 (int c) +{ + return CHAR_BYTE8_P (c) ? c - 0x3FFF00 : c & 0xFF; +} /* Return the raw 8-bit byte for character C, or -1 if C doesn't correspond to a byte. */ -#define CHAR_TO_BYTE_SAFE(c) \ - (ASCII_CHAR_P (c) ? c : (CHAR_BYTE8_P (c) ? (c) - 0x3FFF00 : -1)) +INLINE int +CHAR_TO_BYTE_SAFE (int c) +{ + return ASCII_CHAR_P (c) ? c : CHAR_BYTE8_P (c) ? c - 0x3FFF00 : -1; +} -/* Nonzero iff BYTE is the 1st byte of a multibyte form of a character +/* True iff BYTE is the 1st byte of a multibyte form of a character that corresponds to a raw 8-bit byte. */ -#define CHAR_BYTE8_HEAD_P(byte) ((byte) == 0xC0 || (byte) == 0xC1) - -/* If C is not ASCII, make it unibyte. */ -#define MAKE_CHAR_UNIBYTE(c) \ - do { \ - if (! ASCII_CHAR_P (c)) \ - c = CHAR_TO_BYTE8 (c); \ - } while (false) - +INLINE bool +CHAR_BYTE8_HEAD_P (int byte) +{ + return byte == 0xC0 || byte == 0xC1; +} /* If C is not ASCII, make it multibyte. Assumes C < 256. */ -#define MAKE_CHAR_MULTIBYTE(c) \ - (eassert ((c) >= 0 && (c) < 256), (c) = UNIBYTE_TO_CHAR (c)) +INLINE int +make_char_multibyte (int c) +{ + eassert (SINGLE_BYTE_CHAR_P (c)); + return UNIBYTE_TO_CHAR (c); +} /* This is the maximum byte length of multibyte form. */ -#define MAX_MULTIBYTE_LENGTH 5 - -/* Nonzero iff X is a character. */ -#define CHARACTERP(x) (FIXNATP (x) && XFIXNAT (x) <= MAX_CHAR) +enum { MAX_MULTIBYTE_LENGTH = 5 }; /* Nonzero iff C is valid as a character code. */ -#define CHAR_VALID_P(c) UNSIGNED_CMP (c, <=, MAX_CHAR) +INLINE bool +CHAR_VALID_P (intmax_t c) +{ + return 0 <= c && c <= MAX_CHAR; +} -/* Check if Lisp object X is a character or not. */ -#define CHECK_CHARACTER(x) \ - CHECK_TYPE (CHARACTERP (x), Qcharacterp, x) +/* Nonzero iff X is a character. */ +INLINE bool +CHARACTERP (Lisp_Object x) +{ + return FIXNUMP (x) && CHAR_VALID_P (XFIXNUM (x)); +} -#define CHECK_CHARACTER_CAR(x) \ - do { \ - Lisp_Object tmp = XCAR (x); \ - CHECK_CHARACTER (tmp); \ - } while (false) +/* Check if Lisp object X is a character or not. */ +INLINE void +CHECK_CHARACTER (Lisp_Object x) +{ + CHECK_TYPE (CHARACTERP (x), Qcharacterp, x); +} -#define CHECK_CHARACTER_CDR(x) \ - do { \ - Lisp_Object tmp = XCDR (x); \ - CHECK_CHARACTER (tmp); \ - } while (false) +INLINE void +CHECK_CHARACTER_CAR (Lisp_Object x) +{ + CHECK_CHARACTER (XCAR (x)); +} -/* Nonzero iff C is a character of code less than 0x100. */ -#define SINGLE_BYTE_CHAR_P(c) UNSIGNED_CMP (c, <, 0x100) +INLINE void +CHECK_CHARACTER_CDR (Lisp_Object x) +{ + CHECK_CHARACTER (XCDR (x)); +} -/* Nonzero if character C has a printable glyph. */ -#define CHAR_PRINTABLE_P(c) \ - (((c) >= 32 && (c) < 127) \ - || ! NILP (CHAR_TABLE_REF (Vprintable_chars, (c)))) +/* True if character C has a printable glyph. */ +INLINE bool +CHAR_PRINTABLE_P (int c) +{ + return ((32 <= c && c < 127) + || ! NILP (CHAR_TABLE_REF (Vprintable_chars, c))); +} /* Return byte length of multibyte form for character C. */ -#define CHAR_BYTES(c) \ - ( (c) <= MAX_1_BYTE_CHAR ? 1 \ - : (c) <= MAX_2_BYTE_CHAR ? 2 \ - : (c) <= MAX_3_BYTE_CHAR ? 3 \ - : (c) <= MAX_4_BYTE_CHAR ? 4 \ - : (c) <= MAX_5_BYTE_CHAR ? 5 \ - : 2) - +INLINE int +CHAR_BYTES (int c) +{ + return ((MAX_5_BYTE_CHAR < c ? -2 : 1) + + (MAX_1_BYTE_CHAR < c) + + (MAX_2_BYTE_CHAR < c) + + (MAX_3_BYTE_CHAR < c) + + (MAX_4_BYTE_CHAR < c)); +} /* Return the leading code of multibyte form of C. */ -#define CHAR_LEADING_CODE(c) \ - ((c) <= MAX_1_BYTE_CHAR ? c \ - : (c) <= MAX_2_BYTE_CHAR ? (0xC0 | ((c) >> 6)) \ - : (c) <= MAX_3_BYTE_CHAR ? (0xE0 | ((c) >> 12)) \ - : (c) <= MAX_4_BYTE_CHAR ? (0xF0 | ((c) >> 18)) \ - : (c) <= MAX_5_BYTE_CHAR ? 0xF8 \ - : (0xC0 | (((c) >> 6) & 0x01))) +INLINE int +CHAR_LEADING_CODE (int c) +{ + return (c <= MAX_1_BYTE_CHAR ? c + : c <= MAX_2_BYTE_CHAR ? 0xC0 | (c >> 6) + : c <= MAX_3_BYTE_CHAR ? 0xE0 | (c >> 12) + : c <= MAX_4_BYTE_CHAR ? 0xF0 | (c >> 18) + : c <= MAX_5_BYTE_CHAR ? 0xF8 + : 0xC0 | ((c >> 6) & 0x01)); +} /* Store multibyte form of the character C in P. The caller should allocate at least MAX_MULTIBYTE_LENGTH bytes area at P in advance. Returns the length of the multibyte form. */ -#define CHAR_STRING(c, p) \ - (UNSIGNED_CMP (c, <=, MAX_1_BYTE_CHAR) \ - ? ((p)[0] = (c), \ - 1) \ - : UNSIGNED_CMP (c, <=, MAX_2_BYTE_CHAR) \ - ? ((p)[0] = (0xC0 | ((c) >> 6)), \ - (p)[1] = (0x80 | ((c) & 0x3F)), \ - 2) \ - : UNSIGNED_CMP (c, <=, MAX_3_BYTE_CHAR) \ - ? ((p)[0] = (0xE0 | ((c) >> 12)), \ - (p)[1] = (0x80 | (((c) >> 6) & 0x3F)), \ - (p)[2] = (0x80 | ((c) & 0x3F)), \ - 3) \ - : verify_expr (sizeof (c) <= sizeof (unsigned), char_string (c, p))) +INLINE int +CHAR_STRING (int c, unsigned char *p) +{ + eassume (0 <= c); + if (c <= MAX_1_BYTE_CHAR) + { + p[0] = c; + return 1; + } + if (c <= MAX_2_BYTE_CHAR) + { + p[0] = 0xC0 | (c >> 6); + p[1] = 0x80 | (c & 0x3F); + return 2; + } + if (c <= MAX_3_BYTE_CHAR) + { + p[0] = 0xE0 | (c >> 12); + p[1] = 0x80 | ((c >> 6) & 0x3F); + p[2] = 0x80 | (c & 0x3F); + return 3; + } + int len = char_string (c, p); + eassume (0 < len && len <= MAX_MULTIBYTE_LENGTH); + return len; +} /* Store multibyte form of byte B in P. The caller should allocate at least MAX_MULTIBYTE_LENGTH bytes area at P in advance. Returns the length of the multibyte form. */ -#define BYTE8_STRING(b, p) \ - ((p)[0] = (0xC0 | (((b) >> 6) & 0x01)), \ - (p)[1] = (0x80 | ((b) & 0x3F)), \ - 2) - - -/* Store multibyte form of the character C in P and advance P to the - end of the multibyte form. The caller should allocate at least - MAX_MULTIBYTE_LENGTH bytes area at P in advance. */ - -#define CHAR_STRING_ADVANCE(c, p) \ - do { \ - if ((c) <= MAX_1_BYTE_CHAR) \ - *(p)++ = (c); \ - else if ((c) <= MAX_2_BYTE_CHAR) \ - *(p)++ = (0xC0 | ((c) >> 6)), \ - *(p)++ = (0x80 | ((c) & 0x3F)); \ - else if ((c) <= MAX_3_BYTE_CHAR) \ - *(p)++ = (0xE0 | ((c) >> 12)), \ - *(p)++ = (0x80 | (((c) >> 6) & 0x3F)), \ - *(p)++ = (0x80 | ((c) & 0x3F)); \ - else \ - { \ - verify (sizeof (c) <= sizeof (unsigned)); \ - (p) += char_string (c, p); \ - } \ - } while (false) - - -/* Nonzero iff BYTE starts a non-ASCII character in a multibyte - form. */ -#define LEADING_CODE_P(byte) (((byte) & 0xC0) == 0xC0) - -/* Nonzero iff BYTE is a trailing code of a non-ASCII character in a +INLINE int +BYTE8_STRING (int b, unsigned char *p) +{ + p[0] = 0xC0 | ((b >> 6) & 0x01); + p[1] = 0x80 | (b & 0x3F); + return 2; +} + + +/* True iff BYTE starts a non-ASCII character in a multibyte form. */ +INLINE bool +LEADING_CODE_P (int byte) +{ + return (byte & 0xC0) == 0xC0; +} + +/* True iff BYTE is a trailing code of a non-ASCII character in a multibyte form. */ -#define TRAILING_CODE_P(byte) (((byte) & 0xC0) == 0x80) +INLINE bool +TRAILING_CODE_P (int byte) +{ + return (byte & 0xC0) == 0x80; +} -/* Nonzero iff BYTE starts a character in a multibyte form. +/* True iff BYTE starts a character in a multibyte form. This is equivalent to: (ASCII_CHAR_P (byte) || LEADING_CODE_P (byte)) */ -#define CHAR_HEAD_P(byte) (((byte) & 0xC0) != 0x80) +INLINE bool +CHAR_HEAD_P (int byte) +{ + return (byte & 0xC0) != 0x80; +} /* How many bytes a character that starts with BYTE occupies in a - multibyte form. Unlike MULTIBYTE_LENGTH below, this macro does not + multibyte form. Unlike multibyte_length, this function does not validate the multibyte form, but looks only at its first byte. */ -#define BYTES_BY_CHAR_HEAD(byte) \ - (!((byte) & 0x80) ? 1 \ - : !((byte) & 0x20) ? 2 \ - : !((byte) & 0x10) ? 3 \ - : !((byte) & 0x08) ? 4 \ - : 5) +INLINE int +BYTES_BY_CHAR_HEAD (int byte) +{ + return (!(byte & 0x80) ? 1 + : !(byte & 0x20) ? 2 + : !(byte & 0x10) ? 3 + : !(byte & 0x08) ? 4 + : 5); +} -/* The byte length of multibyte form at unibyte string P ending at - PEND. If the string doesn't point to a valid multibyte form, - return 0. Unlike BYTES_BY_CHAR_HEAD, this macro validates the - multibyte form. */ +/* The byte length of the multibyte form at the unibyte string P, + ending at PEND if CHECK, and without a length check if !CHECK. + If ALLOW_8BIT, allow multibyte forms of eight-bit characters. + If the string doesn't point to a valid multibyte form, return 0. + Unlike BYTES_BY_CHAR_HEAD, this function validates the multibyte form. */ + +INLINE int +multibyte_length (unsigned char const *p, unsigned char const *pend, + bool check, bool allow_8bit) +{ + if (!check || p < pend) + { + unsigned char c = p[0]; + if (c < 0x80) + return 1; + if (!check || p + 1 < pend) + { + unsigned char d = p[1]; + int w = ((d & 0xC0) << 2) + c; + if ((allow_8bit ? 0x2C0 : 0x2C2) <= w && w <= 0x2DF) + return 2; + if (!check || p + 2 < pend) + { + unsigned char e = p[2]; + w += (e & 0xC0) << 4; + int w1 = w | ((d & 0x20) >> 2); + if (0xAE1 <= w1 && w1 <= 0xAEF) + return 3; + if (!check || p + 3 < pend) + { + unsigned char f = p[3]; + w += (f & 0xC0) << 6; + int w2 = w | ((d & 0x30) >> 3); + if (0x2AF1 <= w2 && w2 <= 0x2AF7) + return 4; + if (!check || p + 4 < pend) + { + int_fast64_t lw = w + ((p[4] & 0xC0) << 8), + w3 = (lw << 24) + (d << 16) + (e << 8) + f; + if (0xAAF8888080 <= w3 && w3 <= 0xAAF88FBFBD) + return 5; + } + } + } + } + } + + return 0; +} + -#define MULTIBYTE_LENGTH(p, pend) \ - (p >= pend ? 0 \ - : !((p)[0] & 0x80) ? 1 \ - : ((p + 1 >= pend) || (((p)[1] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xE0) == 0xC0 ? 2 \ - : ((p + 2 >= pend) || (((p)[2] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xF0) == 0xE0 ? 3 \ - : ((p + 3 >= pend) || (((p)[3] & 0xC0) != 0x80)) ? 0 \ - : ((p)[0] & 0xF8) == 0xF0 ? 4 \ - : ((p + 4 >= pend) || (((p)[4] & 0xC0) != 0x80)) ? 0 \ - : (p)[0] == 0xF8 && ((p)[1] & 0xF0) == 0x80 ? 5 \ - : 0) - - -/* Like MULTIBYTE_LENGTH, but don't check the ending address. The - multibyte form is still validated, unlike BYTES_BY_CHAR_HEAD. */ - -#define MULTIBYTE_LENGTH_NO_CHECK(p) \ - (!((p)[0] & 0x80) ? 1 \ - : ((p)[1] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xE0) == 0xC0 ? 2 \ - : ((p)[2] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xF0) == 0xE0 ? 3 \ - : ((p)[3] & 0xC0) != 0x80 ? 0 \ - : ((p)[0] & 0xF8) == 0xF0 ? 4 \ - : ((p)[4] & 0xC0) != 0x80 ? 0 \ - : (p)[0] == 0xF8 && ((p)[1] & 0xF0) == 0x80 ? 5 \ - : 0) - -/* If P is before LIMIT, advance P to the next character boundary. +/* Return number of bytes in the multibyte character just before P. Assumes that P is already at a character boundary of the same - multibyte form whose end address is LIMIT. */ + multibyte form, and is not at the start of that form. */ -#define NEXT_CHAR_BOUNDARY(p, limit) \ - do { \ - if ((p) < (limit)) \ - (p) += BYTES_BY_CHAR_HEAD (*(p)); \ - } while (false) +INLINE int +raw_prev_char_len (unsigned char const *p) +{ + for (int len = 1; ; len++) + if (CHAR_HEAD_P (p[-len])) + return len; +} -/* If P is after LIMIT, advance P to the previous character boundary. - Assumes that P is already at a character boundary of the same - multibyte form whose beginning address is LIMIT. */ - -#define PREV_CHAR_BOUNDARY(p, limit) \ - do { \ - if ((p) > (limit)) \ - { \ - const unsigned char *chp = (p); \ - do { \ - chp--; \ - } while (chp >= limit && ! CHAR_HEAD_P (*chp)); \ - (p) = (BYTES_BY_CHAR_HEAD (*chp) == (p) - chp) ? chp : (p) - 1; \ - } \ - } while (false) +/* Return the character code of character whose multibyte form is at P, + and set *LENGTH to its length. */ + +INLINE int +string_char_and_length (unsigned char const *p, int *length) +{ + int c = p[0]; + if (! (c & 0x80)) + { + *length = 1; + return c; + } + eassume (0xC0 <= c); + + int d = (c << 6) + p[1] - ((0xC0 << 6) + 0x80); + if (! (c & 0x20)) + { + *length = 2; + return d + (c < 0xC2 ? 0x3FFF80 : 0); + } + + d = (d << 6) + p[2] - ((0x20 << 12) + 0x80); + if (! (c & 0x10)) + { + *length = 3; + eassume (MAX_2_BYTE_CHAR < d && d <= MAX_3_BYTE_CHAR); + return d; + } + + d = (d << 6) + p[3] - ((0x10 << 18) + 0x80); + if (! (c & 0x08)) + { + *length = 4; + eassume (MAX_3_BYTE_CHAR < d && d <= MAX_4_BYTE_CHAR); + return d; + } + + d = (d << 6) + p[4] - ((0x08 << 24) + 0x80); + *length = 5; + eassume (MAX_4_BYTE_CHAR < d && d <= MAX_5_BYTE_CHAR); + return d; +} /* Return the character code of character whose multibyte form is at P. */ -#define STRING_CHAR(p) \ - (!((p)[0] & 0x80) \ - ? (p)[0] \ - : ! ((p)[0] & 0x20) \ - ? (((((p)[0] & 0x1F) << 6) \ - | ((p)[1] & 0x3F)) \ - + (((unsigned char) (p)[0]) < 0xC2 ? 0x3FFF80 : 0)) \ - : ! ((p)[0] & 0x10) \ - ? ((((p)[0] & 0x0F) << 12) \ - | (((p)[1] & 0x3F) << 6) \ - | ((p)[2] & 0x3F)) \ - : string_char ((p), NULL, NULL)) - - -/* Like STRING_CHAR, but set ACTUAL_LEN to the length of multibyte - form. */ - -#define STRING_CHAR_AND_LENGTH(p, actual_len) \ - (!((p)[0] & 0x80) \ - ? ((actual_len) = 1, (p)[0]) \ - : ! ((p)[0] & 0x20) \ - ? ((actual_len) = 2, \ - (((((p)[0] & 0x1F) << 6) \ - | ((p)[1] & 0x3F)) \ - + (((unsigned char) (p)[0]) < 0xC2 ? 0x3FFF80 : 0))) \ - : ! ((p)[0] & 0x10) \ - ? ((actual_len) = 3, \ - ((((p)[0] & 0x0F) << 12) \ - | (((p)[1] & 0x3F) << 6) \ - | ((p)[2] & 0x3F))) \ - : string_char ((p), NULL, &actual_len)) - - -/* Like STRING_CHAR, but advance P to the end of multibyte form. */ - -#define STRING_CHAR_ADVANCE(p) \ - (!((p)[0] & 0x80) \ - ? *(p)++ \ - : ! ((p)[0] & 0x20) \ - ? ((p) += 2, \ - ((((p)[-2] & 0x1F) << 6) \ - | ((p)[-1] & 0x3F) \ - | ((unsigned char) ((p)[-2]) < 0xC2 ? 0x3FFF80 : 0))) \ - : ! ((p)[0] & 0x10) \ - ? ((p) += 3, \ - ((((p)[-3] & 0x0F) << 12) \ - | (((p)[-2] & 0x3F) << 6) \ - | ((p)[-1] & 0x3F))) \ - : string_char ((p), &(p), NULL)) - - -/* Fetch the "next" character from Lisp string STRING at byte position - BYTEIDX, character position CHARIDX. Store it into OUTPUT. - - All the args must be side-effect-free. - BYTEIDX and CHARIDX must be lvalues; - we increment them past the character fetched. */ - -#define FETCH_STRING_CHAR_ADVANCE(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (STRING_MULTIBYTE (STRING)) \ - { \ - unsigned char *chp = &SDATA (STRING)[BYTEIDX]; \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = SREF (STRING, BYTEIDX); \ - BYTEIDX++; \ - } \ - } \ - while (false) - -/* Like FETCH_STRING_CHAR_ADVANCE, but return a multibyte character - even if STRING is unibyte. */ +INLINE int +STRING_CHAR (unsigned char const *p) +{ + int len; + return string_char_and_length (p, &len); +} + -#define FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (STRING_MULTIBYTE (STRING)) \ - { \ - unsigned char *chp = &SDATA (STRING)[BYTEIDX]; \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = SREF (STRING, BYTEIDX); \ - BYTEIDX++; \ - MAKE_CHAR_MULTIBYTE (OUTPUT); \ - } \ - } \ - while (false) - - -/* Like FETCH_STRING_CHAR_ADVANCE, but assumes STRING is multibyte. */ - -#define FETCH_STRING_CHAR_ADVANCE_NO_CHECK(OUTPUT, STRING, CHARIDX, BYTEIDX) \ - do \ - { \ - unsigned char *fetch_ptr = &SDATA (STRING)[BYTEIDX]; \ - int fetch_len; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (fetch_ptr, fetch_len); \ - BYTEIDX += fetch_len; \ - CHARIDX++; \ - } \ - while (false) - - -/* Like FETCH_STRING_CHAR_ADVANCE, but fetch character from the current - buffer. */ - -#define FETCH_CHAR_ADVANCE(OUTPUT, CHARIDX, BYTEIDX) \ - do \ - { \ - CHARIDX++; \ - if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - { \ - unsigned char *chp = BYTE_POS_ADDR (BYTEIDX); \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - } \ - else \ - { \ - OUTPUT = *(BYTE_POS_ADDR (BYTEIDX)); \ - BYTEIDX++; \ - } \ - } \ - while (false) - - -/* Like FETCH_CHAR_ADVANCE, but assumes the current buffer is multibyte. */ - -#define FETCH_CHAR_ADVANCE_NO_CHECK(OUTPUT, CHARIDX, BYTEIDX) \ - do \ - { \ - unsigned char *chp = BYTE_POS_ADDR (BYTEIDX); \ - int chlen; \ - \ - OUTPUT = STRING_CHAR_AND_LENGTH (chp, chlen); \ - BYTEIDX += chlen; \ - CHARIDX++; \ - } \ - while (false) - - -/* Increment the buffer byte position POS_BYTE of the current buffer to - the next character boundary. No range checking of POS. */ - -#define INC_POS(pos_byte) \ - do { \ - unsigned char *chp = BYTE_POS_ADDR (pos_byte); \ - pos_byte += BYTES_BY_CHAR_HEAD (*chp); \ - } while (false) - - -/* Decrement the buffer byte position POS_BYTE of the current buffer to - the previous character boundary. No range checking of POS. */ - -#define DEC_POS(pos_byte) \ - do { \ - unsigned char *chp; \ - \ - pos_byte--; \ - if (pos_byte < GPT_BYTE) \ - chp = BEG_ADDR + pos_byte - BEG_BYTE; \ - else \ - chp = BEG_ADDR + GAP_SIZE + pos_byte - BEG_BYTE; \ - while (!CHAR_HEAD_P (*chp)) \ - { \ - chp--; \ - pos_byte--; \ - } \ - } while (false) - -/* Increment both CHARPOS and BYTEPOS, each in the appropriate way. */ - -#define INC_BOTH(charpos, bytepos) \ - do \ - { \ - (charpos)++; \ - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - (bytepos)++; \ - else \ - INC_POS ((bytepos)); \ - } \ - while (false) - - -/* Decrement both CHARPOS and BYTEPOS, each in the appropriate way. */ - -#define DEC_BOTH(charpos, bytepos) \ - do \ - { \ - (charpos)--; \ - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) \ - (bytepos)--; \ - else \ - DEC_POS ((bytepos)); \ - } \ - while (false) - - -/* Increment the buffer byte position POS_BYTE of the current buffer to - the next character boundary. This macro relies on the fact that - *GPT_ADDR and *Z_ADDR are always accessible and the values are - '\0'. No range checking of POS_BYTE. */ - -#define BUF_INC_POS(buf, pos_byte) \ - do { \ - unsigned char *chp = BUF_BYTE_ADDRESS (buf, pos_byte); \ - pos_byte += BYTES_BY_CHAR_HEAD (*chp); \ - } while (false) - - -/* Decrement the buffer byte position POS_BYTE of the current buffer to - the previous character boundary. No range checking of POS_BYTE. */ - -#define BUF_DEC_POS(buf, pos_byte) \ - do { \ - unsigned char *chp; \ - pos_byte--; \ - if (pos_byte < BUF_GPT_BYTE (buf)) \ - chp = BUF_BEG_ADDR (buf) + pos_byte - BEG_BYTE; \ - else \ - chp = BUF_BEG_ADDR (buf) + BUF_GAP_SIZE (buf) + pos_byte - BEG_BYTE;\ - while (!CHAR_HEAD_P (*chp)) \ - { \ - chp--; \ - pos_byte--; \ - } \ - } while (false) - - -/* Return a non-outlandish value for the tab width. */ - -#define SANE_TAB_WIDTH(buf) sanitize_tab_width (BVAR (buf, tab_width)) +/* Like STRING_CHAR (*PP), but advance *PP to the end of multibyte form. */ INLINE int -sanitize_tab_width (Lisp_Object width) +string_char_advance (unsigned char const **pp) { - return (FIXNUMP (width) && 0 < XFIXNUM (width) && XFIXNUM (width) <= 1000 - ? XFIXNUM (width) : 8); + unsigned char const *p = *pp; + int len, c = string_char_and_length (p, &len); + *pp = p + len; + return c; } -/* Return the width of ASCII character C. The width is measured by - how many columns C will occupy on the screen when displayed in the - current buffer. */ -#define ASCII_CHAR_WIDTH(c) \ - (c < 0x20 \ - ? (c == '\t' \ - ? SANE_TAB_WIDTH (current_buffer) \ - : (c == '\n' ? 0 : (NILP (BVAR (current_buffer, ctl_arrow)) ? 4 : 2))) \ - : (c < 0x7f \ - ? 1 \ - : ((NILP (BVAR (current_buffer, ctl_arrow)) ? 4 : 2)))) +/* Return the next character from Lisp string STRING at byte position + *BYTEIDX, character position *CHARIDX. Update *BYTEIDX and + *CHARIDX past the character fetched. */ + +INLINE int +fetch_string_char_advance (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + int output; + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + if (STRING_MULTIBYTE (string)) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = *chp; + b++; + } + (*charidx)++; + *byteidx = b; + return output; +} -/* Return a non-outlandish value for a character width. */ +/* Like fetch_string_char_advance, but return a multibyte character + even if STRING is unibyte. */ INLINE int -sanitize_char_width (EMACS_INT width) +fetch_string_char_as_multibyte_advance (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) { - return 0 <= width && width <= 1000 ? width : 1000; + int output; + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + if (STRING_MULTIBYTE (string)) + { + int chlen; + output = string_char_and_length (chp, &chlen); + b += chlen; + } + else + { + output = make_char_multibyte (*chp); + b++; + } + (*charidx)++; + *byteidx = b; + return output; } -/* Return the width of character C. The width is measured by how many - columns C will occupy on the screen when displayed in the current - buffer. The name CHARACTER_WIDTH avoids a collision with <limits.h> - CHAR_WIDTH when enabled; see ISO/IEC TS 18661-1:2014. */ -#define CHARACTER_WIDTH(c) \ - (ASCII_CHAR_P (c) \ - ? ASCII_CHAR_WIDTH (c) \ - : sanitize_char_width (XFIXNUM (CHAR_TABLE_REF (Vchar_width_table, c)))) +/* Like fetch_string_char_advance, but assumes STRING is multibyte. */ + +INLINE int +fetch_string_char_advance_no_check (Lisp_Object string, + ptrdiff_t *charidx, ptrdiff_t *byteidx) +{ + ptrdiff_t b = *byteidx; + unsigned char *chp = SDATA (string) + b; + int chlen, output = string_char_and_length (chp, &chlen); + (*charidx)++; + *byteidx = b + chlen; + return output; +} + /* If C is a variation selector, return the index of the variation selector (1..256). Otherwise, return 0. */ -#define CHAR_VARIATION_SELECTOR_P(c) \ - ((c) < 0xFE00 ? 0 \ - : (c) <= 0xFE0F ? (c) - 0xFE00 + 1 \ - : (c) < 0xE0100 ? 0 \ - : (c) <= 0xE01EF ? (c) - 0xE0100 + 17 \ - : 0) +INLINE int +CHAR_VARIATION_SELECTOR_P (int c) +{ + return (c < 0xFE00 ? 0 + : c <= 0xFE0F ? c - 0xFE00 + 1 + : c < 0xE0100 ? 0 + : c <= 0xE01EF ? c - 0xE0100 + 17 + : 0); +} /* Return true if C is a surrogate. */ @@ -657,9 +560,6 @@ typedef enum { } unicode_category_t; extern EMACS_INT char_resolve_modifier_mask (EMACS_INT) ATTRIBUTE_CONST; -extern int char_string (unsigned, unsigned char *); -extern int string_char (const unsigned char *, - const unsigned char **, int *); extern int translate_char (Lisp_Object, int c); extern ptrdiff_t count_size_as_multibyte (const unsigned char *, ptrdiff_t); @@ -684,10 +584,6 @@ extern bool graphicp (int); extern bool printablep (int); extern bool blankp (int); -/* Return a translation table of id number ID. */ -#define GET_TRANSLATION_TABLE(id) \ - (XCDR (XVECTOR (Vtranslation_table_vector)->contents[(id)])) - /* Look up the element in char table OBJ at index CH, and return it as an integer. If the element is not a character, return CH itself. */ diff --git a/src/charset.c b/src/charset.c index 2771b0ba2ac..8635aad3ed6 100644 --- a/src/charset.c +++ b/src/charset.c @@ -866,15 +866,10 @@ usage: (define-charset-internal ...) */) val = args[charset_arg_code_space]; for (i = 0, dimension = 0, nchars = 1; ; i++) { - Lisp_Object min_byte_obj, max_byte_obj; - int min_byte, max_byte; - - min_byte_obj = Faref (val, make_fixnum (i * 2)); - max_byte_obj = Faref (val, make_fixnum (i * 2 + 1)); - CHECK_RANGED_INTEGER (min_byte_obj, 0, 255); - min_byte = XFIXNUM (min_byte_obj); - CHECK_RANGED_INTEGER (max_byte_obj, min_byte, 255); - max_byte = XFIXNUM (max_byte_obj); + Lisp_Object min_byte_obj = Faref (val, make_fixnum (i * 2)); + Lisp_Object max_byte_obj = Faref (val, make_fixnum (i * 2 + 1)); + int min_byte = check_integer_range (min_byte_obj, 0, 255); + int max_byte = check_integer_range (max_byte_obj, min_byte, 255); charset.code_space[i * 4] = min_byte; charset.code_space[i * 4 + 1] = max_byte; charset.code_space[i * 4 + 2] = max_byte - min_byte + 1; @@ -887,13 +882,8 @@ usage: (define-charset-internal ...) */) } val = args[charset_arg_dimension]; - if (NILP (val)) - charset.dimension = dimension; - else - { - CHECK_RANGED_INTEGER (val, 1, 4); - charset.dimension = XFIXNUM (val); - } + charset.dimension + = !NILP (val) ? check_integer_range (val, 1, 4) : dimension; charset.code_linear_p = (charset.dimension == 1 @@ -979,13 +969,7 @@ usage: (define-charset-internal ...) */) } val = args[charset_arg_iso_revision]; - if (NILP (val)) - charset.iso_revision = -1; - else - { - CHECK_RANGED_INTEGER (val, -1, 63); - charset.iso_revision = XFIXNUM (val); - } + charset.iso_revision = !NILP (val) ? check_integer_range (val, -1, 63) : -1; val = args[charset_arg_emacs_mule_id]; if (NILP (val)) @@ -1090,8 +1074,7 @@ usage: (define-charset-internal ...) */) car_part = XCAR (elt); cdr_part = XCDR (elt); CHECK_CHARSET_GET_ID (car_part, this_id); - CHECK_TYPE_RANGED_INTEGER (int, cdr_part); - offset = XFIXNUM (cdr_part); + offset = check_integer_range (cdr_part, INT_MIN, INT_MAX); } else { @@ -1477,7 +1460,7 @@ string_xstring_p (Lisp_Object string) while (p < endp) { - int c = STRING_CHAR_ADVANCE (p); + int c = string_char_advance (&p); if (c >= 0x100) return 2; @@ -1521,7 +1504,7 @@ find_charsets_in_text (const unsigned char *ptr, ptrdiff_t nchars, { while (ptr < pend) { - int c = STRING_CHAR_ADVANCE (ptr); + int c = string_char_advance (&ptr); struct charset *charset; if (!NILP (table)) diff --git a/src/chartab.c b/src/chartab.c index 04205ac1032..cb2ced568d9 100644 --- a/src/chartab.c +++ b/src/chartab.c @@ -1117,10 +1117,10 @@ uniprop_table_uncompress (Lisp_Object table, int idx) { /* SIMPLE TABLE */ p++; - idx = STRING_CHAR_ADVANCE (p); + idx = string_char_advance (&p); while (p < pend && idx < chartab_chars[2]) { - int v = STRING_CHAR_ADVANCE (p); + int v = string_char_advance (&p); set_sub_char_table_contents (sub, idx++, v > 0 ? make_fixnum (v) : Qnil); } @@ -1131,13 +1131,13 @@ uniprop_table_uncompress (Lisp_Object table, int idx) p++; for (idx = 0; p < pend; ) { - int v = STRING_CHAR_ADVANCE (p); + int v = string_char_advance (&p); int count = 1; - int len; if (p < pend) { - count = STRING_CHAR_AND_LENGTH (p, len); + int len; + count = string_char_and_length (p, &len); if (count < 128) count = 1; else diff --git a/src/cmds.c b/src/cmds.c index 9914b7a01f7..90526612b7a 100644 --- a/src/cmds.c +++ b/src/cmds.c @@ -31,15 +31,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ static int internal_self_insert (int, EMACS_INT); -DEFUN ("forward-point", Fforward_point, Sforward_point, 1, 1, 0, - doc: /* Return buffer position N characters after (before if N negative) point. */) - (Lisp_Object n) -{ - CHECK_FIXNUM (n); - - return make_fixnum (PT + XFIXNUM (n)); -} - /* Add N to point; or subtract N if FORWARD is false. N defaults to 1. Validate the new location. Return nil. */ static Lisp_Object @@ -398,7 +389,7 @@ internal_self_insert (int c, EMACS_INT n) /* We will delete too many columns. Let's fill columns by spaces so that the remaining text won't move. */ ptrdiff_t actual = PT_BYTE; - DEC_POS (actual); + actual -= prev_char_len (actual); if (FETCH_CHAR (actual) == '\t') /* Rather than add spaces, let's just keep the tab. */ chars_to_delete--; @@ -460,7 +451,10 @@ internal_self_insert (int c, EMACS_INT n) string = concat2 (string, tem); } - replace_range (PT, PT + chars_to_delete, string, 1, 1, 1, 0); + ptrdiff_t to; + if (INT_ADD_WRAPV (PT, chars_to_delete, &to)) + to = PTRDIFF_MAX; + replace_range (PT, to, string, 1, 1, 1, 0); Fforward_char (make_fixnum (n)); } else if (n > 1) @@ -526,7 +520,6 @@ syms_of_cmds (void) This is run after inserting the character. */); Vpost_self_insert_hook = Qnil; - defsubr (&Sforward_point); defsubr (&Sforward_char); defsubr (&Sbackward_char); defsubr (&Sforward_line); diff --git a/src/coding.c b/src/coding.c index ed755b1afcf..071124b4ef1 100644 --- a/src/coding.c +++ b/src/coding.c @@ -643,7 +643,7 @@ growable_destination (struct coding_system *coding) else \ { \ src--; \ - c = - string_char (src, &src, NULL); \ + c = - string_char_advance (&src); \ record_conversion_result \ (coding, CODING_RESULT_INVALID_SRC); \ } \ @@ -728,7 +728,7 @@ growable_destination (struct coding_system *coding) unsigned ch = (c); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ } \ else \ *dst++ = (c); \ @@ -747,11 +747,11 @@ growable_destination (struct coding_system *coding) ch = (c1); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ ch = (c2); \ if (ch >= 0x80) \ ch = BYTE8_TO_CHAR (ch); \ - CHAR_STRING_ADVANCE (ch, dst); \ + dst += CHAR_STRING (ch, dst); \ } \ else \ { \ @@ -884,18 +884,18 @@ record_conversion_result (struct coding_system *coding, /* Store multibyte form of the character C in P, and advance P to the - end of the multibyte form. This used to be like CHAR_STRING_ADVANCE + end of the multibyte form. This used to be like adding CHAR_STRING without ever calling MAYBE_UNIFY_CHAR, but nowadays we don't call - MAYBE_UNIFY_CHAR in CHAR_STRING_ADVANCE. */ + MAYBE_UNIFY_CHAR in CHAR_STRING. */ -#define CHAR_STRING_ADVANCE_NO_UNIFY(c, p) CHAR_STRING_ADVANCE(c, p) +#define CHAR_STRING_ADVANCE_NO_UNIFY(c, p) ((p) += CHAR_STRING (c, p)) /* Return the character code of character whose multibyte form is at P, and advance P to the end of the multibyte form. This used to be - like STRING_CHAR_ADVANCE without ever calling MAYBE_UNIFY_CHAR, but - nowadays STRING_CHAR_ADVANCE doesn't call MAYBE_UNIFY_CHAR. */ + like string_char_advance without ever calling MAYBE_UNIFY_CHAR, but + nowadays string_char_advance doesn't call MAYBE_UNIFY_CHAR. */ -#define STRING_CHAR_ADVANCE_NO_UNIFY(p) STRING_CHAR_ADVANCE(p) +#define STRING_CHAR_ADVANCE_NO_UNIFY(p) string_char_advance (&(p)) /* Set coding->source from coding->src_object. */ @@ -5131,7 +5131,7 @@ decode_coding_ccl (struct coding_system *coding) while (i < 1024 && p < src_end) { source_byteidx[i] = p - src; - source_charbuf[i++] = STRING_CHAR_ADVANCE (p); + source_charbuf[i++] = string_char_advance (&p); } source_byteidx[i] = p - src; } @@ -5308,15 +5308,10 @@ encode_coding_raw_text (struct coding_system *coding) } else { - unsigned char str[MAX_MULTIBYTE_LENGTH], *p0 = str, *p1 = str; - - CHAR_STRING_ADVANCE (c, p1); - do - { - EMIT_ONE_BYTE (*p0); - p0++; - } - while (p0 < p1); + unsigned char str[MAX_MULTIBYTE_LENGTH]; + int len = CHAR_STRING (c, str); + for (int i = 0; i < len; i++) + EMIT_ONE_BYTE (str[i]); } } else @@ -5342,7 +5337,7 @@ encode_coding_raw_text (struct coding_system *coding) else if (CHAR_BYTE8_P (c)) *dst++ = CHAR_TO_BYTE8 (c); else - CHAR_STRING_ADVANCE (c, dst); + dst += CHAR_STRING (c, dst); } } else @@ -7457,7 +7452,7 @@ decode_coding (struct coding_system *coding) if (coding->src_multibyte && CHAR_BYTE8_HEAD_P (*src) && nbytes > 0) { - c = STRING_CHAR_ADVANCE (src); + c = string_char_advance (&src); nbytes--; } else @@ -7551,10 +7546,8 @@ handle_composition_annotation (ptrdiff_t pos, ptrdiff_t limit, len = SCHARS (components); i = i_byte = 0; while (i < len) - { - FETCH_STRING_CHAR_ADVANCE (*buf, components, i, i_byte); - buf++; - } + *buf++ = fetch_string_char_advance (components, + &i, &i_byte); } else if (FIXNUMP (components)) { @@ -7677,15 +7670,17 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, if (! multibytep) { - int bytes; - if (coding->encoder == encode_coding_raw_text || coding->encoder == encode_coding_ccl) c = *src++, pos++; - else if ((bytes = MULTIBYTE_LENGTH (src, src_end)) > 0) - c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos += bytes; else - c = BYTE8_TO_CHAR (*src), src++, pos++; + { + int bytes = multibyte_length (src, src_end, true, true); + if (0 < bytes) + c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos += bytes; + else + c = BYTE8_TO_CHAR (*src), src++, pos++; + } } else c = STRING_CHAR_ADVANCE_NO_UNIFY (src), pos++; @@ -7715,7 +7710,7 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, lookup_buf[0] = c; for (i = 1; i < max_lookup && p < src_end; i++) - lookup_buf[i] = STRING_CHAR_ADVANCE (p); + lookup_buf[i] = string_char_advance (&p); lookup_buf_end = lookup_buf + i; trans = get_translation (trans, lookup_buf, lookup_buf_end, &from_nchars); @@ -7734,7 +7729,7 @@ consume_chars (struct coding_system *coding, Lisp_Object translation_table, for (i = 1; i < to_nchars; i++) *buf++ = XFIXNUM (AREF (trans, i)); for (i = 1; i < from_nchars; i++, pos++) - src += MULTIBYTE_LENGTH_NO_CHECK (src); + src += multibyte_length (src, NULL, false, true); } } @@ -9023,23 +9018,23 @@ DEFUN ("find-coding-systems-region-internal", } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qt; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qt; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } } @@ -9075,7 +9070,7 @@ DEFUN ("find-coding-systems-region-internal", p++; else { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); if (!NILP (char_table_ref (work_table, c))) /* This character was already checked. Ignore it. */ continue; @@ -9208,7 +9203,7 @@ to the string and treated as in `substring'. */) p = GAP_END_ADDR; } - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); if (! (ASCII_CHAR_P (c) && ascii_compatible) && ! char_charset (translate_char (translation_table, c), charset_list, NULL)) @@ -9277,32 +9272,35 @@ is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); - if (XFIXNUM (start) < BEG || XFIXNUM (end) > Z || XFIXNUM (start) > XFIXNUM (end)) + EMACS_INT s = fix_position (start); + EMACS_INT e = fix_position (end); + if (! (BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); if (NILP (BVAR (current_buffer, enable_multibyte_characters))) return Qnil; - start_byte = CHAR_TO_BYTE (XFIXNUM (start)); - end_byte = CHAR_TO_BYTE (XFIXNUM (end)); - if (XFIXNUM (end) - XFIXNUM (start) == end_byte - start_byte) + start_byte = CHAR_TO_BYTE (s); + end_byte = CHAR_TO_BYTE (e); + if (e - s == end_byte - start_byte) return Qnil; - if (XFIXNUM (start) < GPT && XFIXNUM (end) > GPT) + if (s < GPT && GPT < e) { - if ((GPT - XFIXNUM (start)) < (XFIXNUM (end) - GPT)) - move_gap_both (XFIXNUM (start), start_byte); + if (GPT - s < e - GPT) + move_gap_both (s, start_byte); else - move_gap_both (XFIXNUM (end), end_byte); + move_gap_both (e, end_byte); } - pos = XFIXNUM (start); + pos = s; } list = Qnil; for (tail = coding_system_list; CONSP (tail); tail = XCDR (tail)) { elt = XCAR (tail); - attrs = AREF (CODING_SYSTEM_SPEC (elt), 0); + Lisp_Object spec = CODING_SYSTEM_SPEC (elt); + if (!VECTORP (spec)) + xsignal1 (Qcoding_system_error, elt); + attrs = AREF (spec, 0); ASET (attrs, coding_attr_trans_tbl, get_translation_table (attrs, 1, NULL)); list = Fcons (list2 (elt, attrs), list); @@ -9323,7 +9321,7 @@ is nil. */) p++; else { - c = STRING_CHAR_ADVANCE (p); + c = string_char_advance (&p); charset_map_loaded = 0; for (tail = list; CONSP (tail); tail = XCDR (tail)) @@ -9471,6 +9469,17 @@ not fully specified.) */) return code_convert_region (start, end, coding_system, destination, 1, 0); } +/* Whether STRING only contains chars in the 0..127 range. */ +static bool +string_ascii_p (Lisp_Object string) +{ + ptrdiff_t nbytes = SBYTES (string); + for (ptrdiff_t i = 0; i < nbytes; i++) + if (SREF (string, i) > 127) + return false; + return true; +} + Lisp_Object code_convert_string (Lisp_Object string, Lisp_Object coding_system, Lisp_Object dst_object, bool encodep, bool nocopy, @@ -9485,7 +9494,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, if (! norecord) Vlast_coding_system_used = Qno_conversion; if (NILP (dst_object)) - return (nocopy ? Fcopy_sequence (string) : string); + return nocopy ? string : Fcopy_sequence (string); } if (NILP (coding_system)) @@ -9502,7 +9511,28 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, chars = SCHARS (string); bytes = SBYTES (string); - if (BUFFERP (dst_object)) + if (EQ (dst_object, Qt)) + { + /* Fast path for ASCII-only input and an ASCII-compatible coding: + act as identity if no EOL conversion is needed. */ + Lisp_Object attrs = CODING_ID_ATTRS (coding.id); + if (! NILP (CODING_ATTR_ASCII_COMPAT (attrs)) + && (STRING_MULTIBYTE (string) + ? (chars == bytes) : string_ascii_p (string)) + && (EQ (CODING_ID_EOL_TYPE (coding.id), Qunix) + || inhibit_eol_conversion + || ! memchr (SDATA (string), encodep ? '\n' : '\r', bytes))) + { + if (! norecord) + Vlast_coding_system_used = coding_system; + return (nocopy + ? string + : (encodep + ? make_unibyte_string (SSDATA (string), bytes) + : make_multibyte_string (SSDATA (string), bytes, bytes))); + } + } + else if (BUFFERP (dst_object)) { struct buffer *buf = XBUFFER (dst_object); ptrdiff_t buf_pt = BUF_PT (buf); @@ -9524,10 +9554,7 @@ code_convert_string (Lisp_Object string, Lisp_Object coding_system, /* Encode or decode STRING according to CODING_SYSTEM. - Do not set Vlast_coding_system_used. - - This function is called only from macros DECODE_FILE and - ENCODE_FILE, thus we ignore character composition. */ + Do not set Vlast_coding_system_used. */ Lisp_Object code_convert_string_norecord (Lisp_Object string, Lisp_Object coding_system, @@ -9696,7 +9723,7 @@ encode_string_utf_8 (Lisp_Object string, Lisp_Object buffer, || (len == 2 ? ! CHAR_BYTE8_HEAD_P (c) : (EQ (handle_over_uni, Qt) || (len == 4 - && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR)))) + && STRING_CHAR (p) <= MAX_UNICODE_CHAR)))) { p += len; continue; @@ -9978,8 +10005,7 @@ decode_string_utf_8 (Lisp_Object string, const char *str, ptrdiff_t str_len, && (len == 3 || (UTF_8_EXTRA_OCTET_P (p[3]) && len == 4 - && (string_char (p, NULL, NULL) - <= MAX_UNICODE_CHAR)))))) + && STRING_CHAR (p) <= MAX_UNICODE_CHAR))))) { p += len; continue; @@ -10116,8 +10142,7 @@ decode_string_utf_8 (Lisp_Object string, const char *str, ptrdiff_t str_len, mlen++); if (mlen == len && (len <= 3 - || (len == 4 - && string_char (p, NULL, NULL) <= MAX_UNICODE_CHAR) + || (len == 4 && STRING_CHAR (p) <= MAX_UNICODE_CHAR) || EQ (handle_over_uni, Qt))) { p += len; @@ -10297,6 +10322,16 @@ DEFUN ("internal-decode-string-utf-8", Finternal_decode_string_utf_8, #endif /* ENABLE_UTF_8_CONVERTER_TEST */ +/* Encode or decode STRING using CODING_SYSTEM, with the possibility of + returning STRING itself if it equals the result. + Do not set Vlast_coding_system_used. */ +static Lisp_Object +convert_string_nocopy (Lisp_Object string, Lisp_Object coding_system, + bool encodep) +{ + return code_convert_string (string, coding_system, Qt, encodep, 1, 1); +} + /* Encode or decode a file name, to or from a unibyte string suitable for passing to C library functions. */ Lisp_Object @@ -10307,14 +10342,13 @@ decode_file_name (Lisp_Object fname) converts the file names either to UTF-16LE or to the system ANSI codepage internally, depending on the underlying OS; see w32.c. */ if (! NILP (Fcoding_system_p (Qutf_8))) - return code_convert_string_norecord (fname, Qutf_8, 0); + return convert_string_nocopy (fname, Qutf_8, 0); return fname; #else /* !WINDOWSNT */ if (! NILP (Vfile_name_coding_system)) - return code_convert_string_norecord (fname, Vfile_name_coding_system, 0); + return convert_string_nocopy (fname, Vfile_name_coding_system, 0); else if (! NILP (Vdefault_file_name_coding_system)) - return code_convert_string_norecord (fname, - Vdefault_file_name_coding_system, 0); + return convert_string_nocopy (fname, Vdefault_file_name_coding_system, 0); else return fname; #endif @@ -10334,14 +10368,13 @@ encode_file_name (Lisp_Object fname) converts the file names either to UTF-16LE or to the system ANSI codepage internally, depending on the underlying OS; see w32.c. */ if (! NILP (Fcoding_system_p (Qutf_8))) - return code_convert_string_norecord (fname, Qutf_8, 1); + return convert_string_nocopy (fname, Qutf_8, 1); return fname; #else /* !WINDOWSNT */ if (! NILP (Vfile_name_coding_system)) - return code_convert_string_norecord (fname, Vfile_name_coding_system, 1); + return convert_string_nocopy (fname, Vfile_name_coding_system, 1); else if (! NILP (Vdefault_file_name_coding_system)) - return code_convert_string_norecord (fname, - Vdefault_file_name_coding_system, 1); + return convert_string_nocopy (fname, Vdefault_file_name_coding_system, 1); else return fname; #endif @@ -10362,7 +10395,7 @@ representation of the decoded text. This function sets `last-coding-system-used' to the precise coding system used (which may be different from CODING-SYSTEM if CODING-SYSTEM is -not fully specified.) */) +not fully specified.) The function does not change the match data. */) (Lisp_Object string, Lisp_Object coding_system, Lisp_Object nocopy, Lisp_Object buffer) { return code_convert_string (string, coding_system, buffer, @@ -10382,7 +10415,7 @@ case, the return value is the length of the encoded text. This function sets `last-coding-system-used' to the precise coding system used (which may be different from CODING-SYSTEM if CODING-SYSTEM is -not fully specified.) */) +not fully specified.) The function does not change the match data. */) (Lisp_Object string, Lisp_Object coding_system, Lisp_Object nocopy, Lisp_Object buffer) { return code_convert_string (string, coding_system, buffer, @@ -11061,10 +11094,8 @@ usage: (define-coding-system-internal ...) */) else { CHECK_CONS (val); - CHECK_RANGED_INTEGER (XCAR (val), 0, 255); - from = XFIXNUM (XCAR (val)); - CHECK_RANGED_INTEGER (XCDR (val), from, 255); - to = XFIXNUM (XCDR (val)); + from = check_integer_range (XCAR (val), 0, 255); + to = check_integer_range (XCDR (val), from, 255); } for (int i = from; i <= to; i++) SSET (valids, i, 1); @@ -11149,7 +11180,7 @@ usage: (define-coding-system-internal ...) */) val = XCAR (tail); CHECK_CONS (val); CHECK_CHARSET_GET_ID (XCAR (val), id); - CHECK_RANGED_INTEGER (XCDR (val), 0, 3); + check_integer_range (XCDR (val), 0, 3); XSETCAR (val, make_fixnum (id)); } @@ -11745,6 +11776,8 @@ syms_of_coding (void) DEFSYM (Qignored, "ignored"); + DEFSYM (Qutf_8_string_p, "utf-8-string-p"); + defsubr (&Scoding_system_p); defsubr (&Sread_coding_system); defsubr (&Sread_non_nil_coding_system); diff --git a/src/coding.h b/src/coding.h index 91856c5702b..c2a7b2a00ff 100644 --- a/src/coding.h +++ b/src/coding.h @@ -642,11 +642,11 @@ struct coding_system } while (false) /* Encode the file name NAME using the specified coding system - for file names, if any. */ + for file names, if any. May return NAME itself. */ #define ENCODE_FILE(NAME) encode_file_name (NAME) /* Decode the file name NAME using the specified coding system - for file names, if any. */ + for file names, if any. May return NAME itself. */ #define DECODE_FILE(NAME) decode_file_name (NAME) /* Encode the string STR using the specified coding system diff --git a/src/composite.c b/src/composite.c index a5288cb8a25..f96f0b77726 100644 --- a/src/composite.c +++ b/src/composite.c @@ -170,7 +170,6 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, ptrdiff_t hash_index; enum composition_method method; struct composition *cmp; - ptrdiff_t i; int ch; /* Maximum length of a string of glyphs. XftGlyphExtents limits @@ -224,15 +223,15 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, { key = make_uninit_vector (nchars); if (STRINGP (string)) - for (i = 0; i < nchars; i++) + for (ptrdiff_t i = 0; i < nchars; i++) { - FETCH_STRING_CHAR_ADVANCE (ch, string, charpos, bytepos); + ch = fetch_string_char_advance (string, &charpos, &bytepos); ASET (key, i, make_fixnum (ch)); } else - for (i = 0; i < nchars; i++) + for (ptrdiff_t i = 0; i < nchars; i++) { - FETCH_CHAR_ADVANCE (ch, charpos, bytepos); + ch = fetch_char_advance (&charpos, &bytepos); ASET (key, i, make_fixnum (ch)); } } @@ -273,7 +272,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, /* COMPONENTS is a glyph-string. */ ptrdiff_t len = ASIZE (key); - for (i = 1; i < len; i++) + for (ptrdiff_t i = 1; i < len; i++) if (! VECTORP (AREF (key, i))) goto invalid_composition; } @@ -286,7 +285,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, goto invalid_composition; /* All elements should be integers (character or encoded composition rule). */ - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) { if (!FIXNUMP (key_contents[i])) goto invalid_composition; @@ -328,7 +327,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, { /* Relative composition. */ cmp->width = 0; - for (i = 0; i < glyph_len; i++) + for (ptrdiff_t i = 0; i < glyph_len; i++) { int this_width; ch = XFIXNUM (key_contents[i]); @@ -347,7 +346,7 @@ get_composition_id (ptrdiff_t charpos, ptrdiff_t bytepos, ptrdiff_t nchars, ch = XFIXNUM (key_contents[0]); rightmost = ch != '\t' ? CHARACTER_WIDTH (ch) : 1; - for (i = 1; i < glyph_len; i += 2) + for (ptrdiff_t i = 1; i < glyph_len; i += 2) { int rule, gref, nref; int this_width; @@ -800,12 +799,10 @@ fill_gstring_header (ptrdiff_t from, ptrdiff_t from_byte, ASET (header, 0, font_object); for (ptrdiff_t i = 0; i < len; i++) { - int c; - - if (NILP (string)) - FETCH_CHAR_ADVANCE_NO_CHECK (c, from, from_byte); - else - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, from, from_byte); + int c + = (NILP (string) + ? fetch_char_advance_no_check (&from, &from_byte) + : fetch_string_char_advance_no_check (string, &from, &from_byte)); ASET (header, i + 1, make_fixnum (c)); } return header; @@ -1012,10 +1009,9 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, /* Forward search. */ while (charpos < endpos) { - if (STRINGP (string)) - FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos); - else - FETCH_CHAR_ADVANCE (c, charpos, bytepos); + c = (STRINGP (string) + ? fetch_string_char_advance (string, &charpos, &bytepos) + : fetch_char_advance (&charpos, &bytepos)); if (c == '\n') { cmp_it->ch = -2; @@ -1070,7 +1066,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, p = BYTE_POS_ADDR (bytepos); else p = SDATA (string) + bytepos; - c = STRING_CHAR_AND_LENGTH (p, len); + c = string_char_and_length (p, &len); limit = bytepos + len; while (char_composable_p (c)) { @@ -1132,7 +1128,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, } else { - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); p = BYTE_POS_ADDR (bytepos); } c = STRING_CHAR (p); @@ -1145,7 +1141,7 @@ composition_compute_stop_pos (struct composition_it *cmp_it, ptrdiff_t charpos, { while (charpos - 1 > endpos && ! char_composable_p (c)) { - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); c = FETCH_MULTIBYTE_CHAR (bytepos); } } @@ -1303,7 +1299,7 @@ composition_reseat_it (struct composition_it *cmp_it, ptrdiff_t charpos, { charpos++; if (NILP (string)) - INC_POS (bytepos); + bytepos += next_char_len (bytepos); else bytepos += BYTES_BY_CHAR_HEAD (*(SDATA (string) + bytepos)); } @@ -1769,7 +1765,18 @@ should be ignored. */) CHECK_STRING (string); validate_subarray (string, from, to, SCHARS (string), &frompos, &topos); if (! STRING_MULTIBYTE (string)) - error ("Attempt to shape unibyte text"); + { + ptrdiff_t i; + + for (i = SBYTES (string) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (string, i))) + error ("Attempt to shape unibyte text"); + /* STRING is a pure-ASCII string, so we can convert it (or, + rather, its copy) to multibyte and use that thereafter. */ + Lisp_Object string_copy = Fconcat (1, &string); + STRING_SET_MULTIBYTE (string_copy); + string = string_copy; + } frombyte = string_char_to_byte (string, frompos); } @@ -1841,27 +1848,24 @@ See `find-composition' for more details. */) ptrdiff_t start, end, from, to; int id; - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT fixed_pos = fix_position (pos); if (!NILP (limit)) - { - CHECK_FIXNUM_COERCE_MARKER (limit); - to = min (XFIXNUM (limit), ZV); - } + to = clip_to_bounds (PTRDIFF_MIN, fix_position (limit), ZV); else to = -1; if (!NILP (string)) { CHECK_STRING (string); - if (XFIXNUM (pos) < 0 || XFIXNUM (pos) > SCHARS (string)) + if (! (0 <= fixed_pos && fixed_pos <= SCHARS (string))) args_out_of_range (string, pos); } else { - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV <= fixed_pos && fixed_pos <= ZV)) args_out_of_range (Fcurrent_buffer (), pos); } - from = XFIXNUM (pos); + from = fixed_pos; if (!find_composition (from, to, &start, &end, &prop, string)) { @@ -1872,12 +1876,12 @@ See `find-composition' for more details. */) return list3 (make_fixnum (start), make_fixnum (end), gstring); return Qnil; } - if ((end <= XFIXNUM (pos) || start > XFIXNUM (pos))) + if (! (start <= fixed_pos && fixed_pos < end)) { ptrdiff_t s, e; if (find_automatic_composition (from, to, &s, &e, &gstring, string) - && (e <= XFIXNUM (pos) ? e > end : s < start)) + && (e <= fixed_pos ? e > end : s < start)) return list3 (make_fixnum (s), make_fixnum (e), gstring); } if (!composition_valid_p (start, end, prop)) @@ -1996,7 +2000,9 @@ preceding and/or following characters, this char-table contains a function to call to compose that character. The element at index C in the table, if non-nil, is a list of -composition rules of this form: ([PATTERN PREV-CHARS FUNC] ...) +composition rules of the form ([PATTERN PREV-CHARS FUNC] ...); +the rules must be specified in the descending order of PREV-CHARS +values. PATTERN is a regular expression which C and the surrounding characters must match. diff --git a/src/composite.h b/src/composite.h index 62c4de40e3b..239f1e531ef 100644 --- a/src/composite.h +++ b/src/composite.h @@ -125,10 +125,13 @@ composition_registered_p (Lisp_Object prop) COMPOSITION_DECODE_REFS (rule_code, gref, nref); \ } while (false) -/* Nonzero if the global reference point GREF and new reference point NREF are +/* True if the global reference point GREF and new reference point NREF are valid. */ -#define COMPOSITION_ENCODE_RULE_VALID(gref, nref) \ - (UNSIGNED_CMP (gref, <, 12) && UNSIGNED_CMP (nref, <, 12)) +INLINE bool +COMPOSITION_ENCODE_RULE_VALID (int gref, int nref) +{ + return 0 <= gref && gref < 12 && 0 <= nref && nref < 12; +} /* Return encoded composition rule for the pair of global reference point GREF and new reference point NREF. Arguments must be valid. */ diff --git a/src/conf_post.h b/src/conf_post.h index 2f8d19fdca8..1ef4ff33428 100644 --- a/src/conf_post.h +++ b/src/conf_post.h @@ -30,13 +30,15 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif /* To help make dependencies clearer elsewhere, this file typically - does not #include other files. The exceptions are first stdbool.h + does not #include other files. The exceptions are stdbool.h because it is unlikely to interfere with configuration and bool is - such a core part of the C language, and second ms-w32.h (DOS_NT + such a core part of the C language, attribute.h because its + ATTRIBUTE_* macros are used here, and ms-w32.h (DOS_NT only) because it historically was included here and changing that would take some work. */ #include <stdbool.h> +#include <attribute.h> #if defined WINDOWSNT && !defined DEFER_MS_W32_H # include <ms-w32.h> @@ -65,30 +67,31 @@ typedef unsigned int bool_bf; typedef bool bool_bf; #endif -/* Simulate __has_attribute on compilers that lack it. It is used only - on arguments like alloc_size that are handled in this simulation. - __has_attribute should be used only in #if expressions, as Oracle +/* A substitute for __has_attribute on compilers that lack it. + It is used only on arguments like cleanup that are handled here. + This macro should be used only in #if expressions, as Oracle Studio 12.5's __has_attribute does not work in plain code. */ -#ifndef __has_attribute -# define __has_attribute(a) __has_attribute_##a -# define __has_attribute_alloc_size GNUC_PREREQ (4, 3, 0) -# define __has_attribute_cleanup GNUC_PREREQ (3, 4, 0) -# define __has_attribute_cold GNUC_PREREQ (4, 3, 0) -# define __has_attribute_externally_visible GNUC_PREREQ (4, 1, 0) -# define __has_attribute_no_address_safety_analysis false -# define __has_attribute_no_sanitize_address GNUC_PREREQ (4, 8, 0) -# define __has_attribute_no_sanitize_undefined GNUC_PREREQ (4, 9, 0) -# define __has_attribute_warn_unused_result GNUC_PREREQ (3, 4, 0) +#ifdef __has_attribute +# define HAS_ATTRIBUTE(a) __has_attribute (__##a##__) +#else +# define HAS_ATTRIBUTE(a) HAS_ATTR_##a +# define HAS_ATTR_cleanup GNUC_PREREQ (3, 4, 0) +# define HAS_ATTR_no_address_safety_analysis false +# define HAS_ATTR_no_sanitize false +# define HAS_ATTR_no_sanitize_address GNUC_PREREQ (4, 8, 0) +# define HAS_ATTR_no_sanitize_undefined GNUC_PREREQ (4, 9, 0) #endif -/* Simulate __has_feature on compilers that lack it. It is used only +/* A substitute for __has_feature on compilers that lack it. It is used only to define ADDRESS_SANITIZER below. */ -#ifndef __has_feature -# define __has_feature(a) false +#ifdef __has_feature +# define HAS_FEATURE(a) __has_feature (a) +#else +# define HAS_FEATURE(a) false #endif /* True if addresses are being sanitized. */ -#if defined __SANITIZE_ADDRESS__ || __has_feature (address_sanitizer) +#if defined __SANITIZE_ADDRESS__ || HAS_FEATURE (address_sanitizer) # define ADDRESS_SANITIZER true #else # define ADDRESS_SANITIZER false @@ -225,37 +228,8 @@ extern void _DebPrint (const char *fmt, ...); extern char *emacs_getenv_TZ (void); extern int emacs_setenv_TZ (char const *); -/* Avoid __attribute__ ((cold)) on MinGW; see thread starting at - <https://lists.gnu.org/r/emacs-devel/2019-04/msg01152.html>. */ -#if __has_attribute (cold) && !defined __MINGW32__ -# define ATTRIBUTE_COLD __attribute__ ((cold)) -#else -# define ATTRIBUTE_COLD -#endif - -#if __GNUC__ >= 3 /* On GCC 3.0 we might get a warning. */ -#define NO_INLINE __attribute__((noinline)) -#else -#define NO_INLINE -#endif - -#if __has_attribute (externally_visible) -#define EXTERNALLY_VISIBLE __attribute__((externally_visible)) -#else -#define EXTERNALLY_VISIBLE -#endif - -#if GNUC_PREREQ (2, 7, 0) -# define ATTRIBUTE_FORMAT(spec) __attribute__ ((__format__ spec)) -#else -# define ATTRIBUTE_FORMAT(spec) /* empty */ -#endif - -#if GNUC_PREREQ (7, 0, 0) -# define FALLTHROUGH __attribute__ ((__fallthrough__)) -#else -# define FALLTHROUGH ((void) 0) -#endif +#define NO_INLINE ATTRIBUTE_NOINLINE +#define EXTERNALLY_VISIBLE ATTRIBUTE_EXTERNALLY_VISIBLE #if GNUC_PREREQ (4, 4, 0) && defined __GLIBC_MINOR__ # define PRINTF_ARCHETYPE __gnu_printf__ @@ -287,15 +261,8 @@ extern int emacs_setenv_TZ (char const *); #define ATTRIBUTE_FORMAT_PRINTF(string_index, first_to_check) \ ATTRIBUTE_FORMAT ((PRINTF_ARCHETYPE, string_index, first_to_check)) -#define ARG_NONNULL _GL_ARG_NONNULL -#define ATTRIBUTE_CONST _GL_ATTRIBUTE_CONST -#define ATTRIBUTE_UNUSED _GL_UNUSED - -#if GNUC_PREREQ (3, 3, 0) && !defined __ICC -# define ATTRIBUTE_MAY_ALIAS __attribute__ ((__may_alias__)) -#else -# define ATTRIBUTE_MAY_ALIAS -#endif +#define ARG_NONNULL ATTRIBUTE_NONNULL +#define ATTRIBUTE_UNUSED MAYBE_UNUSED /* Declare NAME to be a pointer to an object of type TYPE, initialized to the address ADDR, which may be of a different type. Accesses @@ -306,19 +273,11 @@ extern int emacs_setenv_TZ (char const *); type ATTRIBUTE_MAY_ALIAS *name = (type *) (addr) #if 3 <= __GNUC__ -# define ATTRIBUTE_MALLOC __attribute__ ((__malloc__)) # define ATTRIBUTE_SECTION(name) __attribute__((section (name))) #else -# define ATTRIBUTE_MALLOC #define ATTRIBUTE_SECTION(name) #endif -#if __has_attribute (alloc_size) -# define ATTRIBUTE_ALLOC_SIZE(args) __attribute__ ((__alloc_size__ args)) -#else -# define ATTRIBUTE_ALLOC_SIZE(args) -#endif - #define ATTRIBUTE_MALLOC_SIZE(args) ATTRIBUTE_MALLOC ATTRIBUTE_ALLOC_SIZE (args) /* Work around GCC bug 59600: when a function is inlined, the inlined @@ -336,10 +295,10 @@ extern int emacs_setenv_TZ (char const *); /* Attribute of functions whose code should not have addresses sanitized. */ -#if __has_attribute (no_sanitize_address) +#if HAS_ATTRIBUTE (no_sanitize_address) # define ATTRIBUTE_NO_SANITIZE_ADDRESS \ __attribute__ ((no_sanitize_address)) ADDRESS_SANITIZER_WORKAROUND -#elif __has_attribute (no_address_safety_analysis) +#elif HAS_ATTRIBUTE (no_address_safety_analysis) # define ATTRIBUTE_NO_SANITIZE_ADDRESS \ __attribute__ ((no_address_safety_analysis)) ADDRESS_SANITIZER_WORKAROUND #else @@ -348,9 +307,9 @@ extern int emacs_setenv_TZ (char const *); /* Attribute of functions whose undefined behavior should not be sanitized. */ -#if __has_attribute (no_sanitize_undefined) +#if HAS_ATTRIBUTE (no_sanitize_undefined) # define ATTRIBUTE_NO_SANITIZE_UNDEFINED __attribute__ ((no_sanitize_undefined)) -#elif __has_attribute (no_sanitize) +#elif HAS_ATTRIBUTE (no_sanitize) # define ATTRIBUTE_NO_SANITIZE_UNDEFINED \ __attribute__ ((no_sanitize ("undefined"))) #else @@ -425,15 +384,13 @@ extern int emacs_setenv_TZ (char const *); #else -/* Use 'static' instead of 'extern inline' because 'static' typically - has better performance for Emacs. Do not use the 'inline' keyword, - as modern compilers inline automatically. ATTRIBUTE_UNUSED - pacifies gcc -Wunused-function. */ +/* Use 'static inline' instead of 'extern inline' because 'static inline' + has much better performance for Emacs when compiled with 'gcc -Og'. */ # ifndef INLINE # define INLINE EXTERN_INLINE # endif -# define EXTERN_INLINE static ATTRIBUTE_UNUSED +# define EXTERN_INLINE static inline # define INLINE_HEADER_BEGIN # define INLINE_HEADER_END diff --git a/src/data.c b/src/data.c index 0f3ac8c6571..1db0a983b49 100644 --- a/src/data.c +++ b/src/data.c @@ -143,15 +143,9 @@ wrong_length_argument (Lisp_Object a1, Lisp_Object a2, Lisp_Object a3) } AVOID -wrong_type_argument (register Lisp_Object predicate, register Lisp_Object value) +wrong_type_argument (Lisp_Object predicate, Lisp_Object value) { - /* If VALUE is not even a valid Lisp object, we'd want to abort here - where we can get a backtrace showing where it came from. We used - to try and do that by checking the tagbits, but nowadays all - tagbits are potentially valid. */ - /* if ((unsigned int) XTYPE (value) >= Lisp_Type_Limit) - * emacs_abort (); */ - + eassert (!TAGGEDP (value, Lisp_Type_Unused0)); xsignal2 (Qwrong_type_argument, predicate, value); } @@ -2305,61 +2299,45 @@ bool-vector. IDX starts at 0. */) } else /* STRINGP */ { - int c; - CHECK_IMPURE (array, XSTRING (array)); if (idxval < 0 || idxval >= SCHARS (array)) args_out_of_range (array, idx); CHECK_CHARACTER (newelt); - c = XFIXNAT (newelt); + int c = XFIXNAT (newelt); + ptrdiff_t idxval_byte; + int prev_bytes; + unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; if (STRING_MULTIBYTE (array)) { - ptrdiff_t idxval_byte, nbytes; - int prev_bytes, new_bytes; - unsigned char workbuf[MAX_MULTIBYTE_LENGTH], *p0 = workbuf, *p1; - - nbytes = SBYTES (array); idxval_byte = string_char_to_byte (array, idxval); p1 = SDATA (array) + idxval_byte; prev_bytes = BYTES_BY_CHAR_HEAD (*p1); - new_bytes = CHAR_STRING (c, p0); - if (prev_bytes != new_bytes) - { - /* We must relocate the string data. */ - ptrdiff_t nchars = SCHARS (array); - USE_SAFE_ALLOCA; - unsigned char *str = SAFE_ALLOCA (nbytes); - - memcpy (str, SDATA (array), nbytes); - allocate_string_data (XSTRING (array), nchars, - nbytes + new_bytes - prev_bytes); - memcpy (SDATA (array), str, idxval_byte); - p1 = SDATA (array) + idxval_byte; - memcpy (p1 + new_bytes, str + idxval_byte + prev_bytes, - nbytes - (idxval_byte + prev_bytes)); - SAFE_FREE (); - clear_string_char_byte_cache (); - } - while (new_bytes--) - *p1++ = *p0++; } - else + else if (SINGLE_BYTE_CHAR_P (c)) { - if (! SINGLE_BYTE_CHAR_P (c)) - { - ptrdiff_t i; - - for (i = SBYTES (array) - 1; i >= 0; i--) - if (SREF (array, i) >= 0x80) - args_out_of_range (array, newelt); - /* ARRAY is an ASCII string. Convert it to a multibyte - string, and try `aset' again. */ - STRING_SET_MULTIBYTE (array); - return Faset (array, idx, newelt); - } SSET (array, idxval, c); + return newelt; + } + else + { + for (ptrdiff_t i = SBYTES (array) - 1; i >= 0; i--) + if (!ASCII_CHAR_P (SREF (array, i))) + args_out_of_range (array, newelt); + /* ARRAY is an ASCII string. Convert it to a multibyte string. */ + STRING_SET_MULTIBYTE (array); + idxval_byte = idxval; + p1 = SDATA (array) + idxval_byte; + prev_bytes = 1; } + + int new_bytes = CHAR_STRING (c, p0); + if (prev_bytes != new_bytes) + p1 = resize_string_data (array, idxval_byte, prev_bytes, new_bytes); + + do + *p1++ = *p0++; + while (--new_bytes != 0); } return newelt; @@ -2367,6 +2345,24 @@ bool-vector. IDX starts at 0. */) /* Arithmetic functions */ +static Lisp_Object +check_integer_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (INTEGERP (x), Qinteger_or_marker_p, x); + return x; +} + +static Lisp_Object +check_number_coerce_marker (Lisp_Object x) +{ + if (MARKERP (x)) + return make_fixnum (marker_position (x)); + CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); + return x; +} + Lisp_Object arithcompare (Lisp_Object num1, Lisp_Object num2, enum Arith_Comparison comparison) @@ -2375,8 +2371,8 @@ arithcompare (Lisp_Object num1, Lisp_Object num2, bool lt, eq = true, gt; bool test; - CHECK_NUMBER_COERCE_MARKER (num1); - CHECK_NUMBER_COERCE_MARKER (num2); + num1 = check_number_coerce_marker (num1); + num2 = check_number_coerce_marker (num2); /* If the comparison is mostly done by comparing two doubles, set LT, EQ, and GT to the <, ==, > results of that comparison, @@ -2778,9 +2774,7 @@ floatop_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_float (accum); - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); - next = XFLOATINT (val); + next = XFLOATINT (check_number_coerce_marker (args[argnum])); } } @@ -2842,8 +2836,7 @@ bignum_arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_integer_mpz (); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); if (FLOATP (val)) return float_arith_driver (code, nargs, args, argnum, mpz_get_d_rounded (*accum), val); @@ -2872,8 +2865,7 @@ arith_driver (enum arithop code, ptrdiff_t nargs, Lisp_Object *args, argnum++; if (argnum == nargs) return make_int (accum); - val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + val = check_number_coerce_marker (args[argnum]); /* Set NEXT to the next value if it fits, else exit the loop. */ intmax_t next; @@ -2920,8 +2912,7 @@ usage: (+ &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Aadd, nargs, args, a); } @@ -2934,8 +2925,7 @@ usage: (- &optional NUMBER-OR-MARKER &rest MORE-NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -2955,8 +2945,7 @@ usage: (* &rest NUMBERS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (1); - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Amult, nargs, args, a); } @@ -2968,8 +2957,7 @@ The arguments must be numbers or markers. usage: (/ NUMBER &rest DIVISORS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object a = args[0]; - CHECK_NUMBER_COERCE_MARKER (a); + Lisp_Object a = check_number_coerce_marker (args[0]); if (nargs == 1) { if (FIXNUMP (a)) @@ -3051,10 +3039,10 @@ integer_remainder (Lisp_Object num, Lisp_Object den, bool modulo) DEFUN ("%", Frem, Srem, 2, 2, 0, doc: /* Return remainder of X divided by Y. Both must be integers or markers. */) - (register Lisp_Object x, Lisp_Object y) + (Lisp_Object x, Lisp_Object y) { - CHECK_INTEGER_COERCE_MARKER (x); - CHECK_INTEGER_COERCE_MARKER (y); + x = check_integer_coerce_marker (x); + y = check_integer_coerce_marker (y); return integer_remainder (x, y, false); } @@ -3064,8 +3052,8 @@ The result falls between zero (inclusive) and Y (exclusive). Both X and Y must be numbers or markers. */) (Lisp_Object x, Lisp_Object y) { - CHECK_NUMBER_COERCE_MARKER (x); - CHECK_NUMBER_COERCE_MARKER (y); + x = check_number_coerce_marker (x); + y = check_number_coerce_marker (y); if (FLOATP (x) || FLOATP (y)) return fmod_float (x, y); return integer_remainder (x, y, true); @@ -3075,12 +3063,10 @@ static Lisp_Object minmax_driver (ptrdiff_t nargs, Lisp_Object *args, enum Arith_Comparison comparison) { - Lisp_Object accum = args[0]; - CHECK_NUMBER_COERCE_MARKER (accum); + Lisp_Object accum = check_number_coerce_marker (args[0]); for (ptrdiff_t argnum = 1; argnum < nargs; argnum++) { - Lisp_Object val = args[argnum]; - CHECK_NUMBER_COERCE_MARKER (val); + Lisp_Object val = check_number_coerce_marker (args[argnum]); if (!NILP (arithcompare (val, accum, comparison))) accum = val; else if (FLOATP (val) && isnan (XFLOAT_DATA (val))) @@ -3115,8 +3101,7 @@ usage: (logand &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (-1); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogand, nargs, args, a); } @@ -3128,8 +3113,7 @@ usage: (logior &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogior, nargs, args, a); } @@ -3141,8 +3125,7 @@ usage: (logxor &rest INTS-OR-MARKERS) */) { if (nargs == 0) return make_fixnum (0); - Lisp_Object a = args[0]; - CHECK_INTEGER_COERCE_MARKER (a); + Lisp_Object a = check_integer_coerce_marker (args[0]); return nargs == 1 ? a : arith_driver (Alogxor, nargs, args, a); } @@ -3261,9 +3244,9 @@ expt_integer (Lisp_Object x, Lisp_Object y) DEFUN ("1+", Fadd1, Sadd1, 1, 1, 0, doc: /* Return NUMBER plus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) + 1); @@ -3276,9 +3259,9 @@ Markers are converted to integers. */) DEFUN ("1-", Fsub1, Ssub1, 1, 1, 0, doc: /* Return NUMBER minus one. NUMBER may be a number or a marker. Markers are converted to integers. */) - (register Lisp_Object number) + (Lisp_Object number) { - CHECK_NUMBER_COERCE_MARKER (number); + number = check_number_coerce_marker (number); if (FIXNUMP (number)) return make_int (XFIXNUM (number) - 1); @@ -3322,27 +3305,14 @@ bool_vector_spare_mask (EMACS_INT nr_bits) return (((bits_word) 1) << (nr_bits % BITS_PER_BITS_WORD)) - 1; } -/* Info about unsigned long long, falling back on unsigned long - if unsigned long long is not available. */ - -#if HAVE_UNSIGNED_LONG_LONG_INT && defined ULLONG_WIDTH -enum { ULL_WIDTH = ULLONG_WIDTH }; -# define ULL_MAX ULLONG_MAX -#else -enum { ULL_WIDTH = ULONG_WIDTH }; -# define ULL_MAX ULONG_MAX -# define count_one_bits_ll count_one_bits_l -# define count_trailing_zeros_ll count_trailing_zeros_l -#endif - /* Shift VAL right by the width of an unsigned long long. - ULL_WIDTH must be less than BITS_PER_BITS_WORD. */ + ULLONG_WIDTH must be less than BITS_PER_BITS_WORD. */ static bits_word shift_right_ull (bits_word w) { /* Pacify bogus GCC warning about shift count exceeding type width. */ - int shift = ULL_WIDTH - BITS_PER_BITS_WORD < 0 ? ULL_WIDTH : 0; + int shift = ULLONG_WIDTH - BITS_PER_BITS_WORD < 0 ? ULLONG_WIDTH : 0; return w >> shift; } @@ -3359,7 +3329,7 @@ count_one_bits_word (bits_word w) { int i = 0, count = 0; while (count += count_one_bits_ll (w), - (i += ULL_WIDTH) < BITS_PER_BITS_WORD) + (i += ULLONG_WIDTH) < BITS_PER_BITS_WORD) w = shift_right_ull (w); return count; } @@ -3490,7 +3460,7 @@ count_trailing_zero_bits (bits_word val) return count_trailing_zeros (val); if (BITS_WORD_MAX == ULONG_MAX) return count_trailing_zeros_l (val); - if (BITS_WORD_MAX == ULL_MAX) + if (BITS_WORD_MAX == ULLONG_MAX) return count_trailing_zeros_ll (val); /* The rest of this code is for the unlikely platform where bits_word differs @@ -3504,18 +3474,18 @@ count_trailing_zero_bits (bits_word val) { int count; for (count = 0; - count < BITS_PER_BITS_WORD - ULL_WIDTH; - count += ULL_WIDTH) + count < BITS_PER_BITS_WORD - ULLONG_WIDTH; + count += ULLONG_WIDTH) { - if (val & ULL_MAX) + if (val & ULLONG_MAX) return count + count_trailing_zeros_ll (val); val = shift_right_ull (val); } - if (BITS_PER_BITS_WORD % ULL_WIDTH != 0 + if (BITS_PER_BITS_WORD % ULLONG_WIDTH != 0 && BITS_WORD_MAX == (bits_word) -1) val |= (bits_word) 1 << pre_value (ULONG_MAX < BITS_WORD_MAX, - BITS_PER_BITS_WORD % ULL_WIDTH); + BITS_PER_BITS_WORD % ULLONG_WIDTH); return count + count_trailing_zeros_ll (val); } } @@ -3528,10 +3498,8 @@ bits_word_to_host_endian (bits_word val) #else if (BITS_WORD_MAX >> 31 == 1) return bswap_32 (val); -# if HAVE_UNSIGNED_LONG_LONG if (BITS_WORD_MAX >> 31 >> 31 >> 1 == 1) return bswap_64 (val); -# endif { int i; bits_word r = 0; diff --git a/src/deps.mk b/src/deps.mk index a7e1b559173..4d162eeb0f2 100644 --- a/src/deps.mk +++ b/src/deps.mk @@ -239,9 +239,6 @@ xfont.o: dispextern.h xterm.h frame.h blockinput.h character.h charset.h \ xftfont.o: xftfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ fontset.h ccl.h ftfont.h composite.h -ftxfont.o: ftxfont.c dispextern.h xterm.h frame.h blockinput.h character.h \ - charset.h font.h lisp.h globals.h $(config_h) atimer.h systime.h \ - fontset.h ccl.h menu.o: menu.c lisp.h keyboard.h keymap.h frame.h termhooks.h blockinput.h \ dispextern.h $(srcdir)/../lwlib/lwlib.h xterm.h gtkutil.h menu.h \ lisp.h globals.h $(config_h) systime.h coding.h composite.h window.h \ diff --git a/src/dired.c b/src/dired.c index 611477aa4ef..f013a4cea03 100644 --- a/src/dired.c +++ b/src/dired.c @@ -937,7 +937,7 @@ file_attributes (int fd, char const *name, int err = EINVAL; #if defined O_PATH && !defined HAVE_CYGWIN_O_PATH_BUG - int namefd = openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW); + int namefd = emacs_openat (fd, name, O_PATH | O_CLOEXEC | O_NOFOLLOW, 0); if (namefd < 0) err = errno; else @@ -970,7 +970,7 @@ file_attributes (int fd, char const *name, information to be accurate. */ w32_stat_get_owner_group = 1; #endif - err = fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; + err = emacs_fstatat (fd, name, &s, AT_SYMLINK_NOFOLLOW) == 0 ? 0 : errno; #ifdef WINDOWSNT w32_stat_get_owner_group = 0; #endif diff --git a/src/dispextern.h b/src/dispextern.h index 724aad4227e..e1d6eddc419 100644 --- a/src/dispextern.h +++ b/src/dispextern.h @@ -234,7 +234,7 @@ struct text_pos { \ ++(POS).charpos; \ if (MULTIBYTE_P) \ - INC_POS ((POS).bytepos); \ + (POS).bytepos += next_char_len ((POS).bytepos); \ else \ ++(POS).bytepos; \ } \ @@ -247,7 +247,7 @@ struct text_pos { \ --(POS).charpos; \ if (MULTIBYTE_P) \ - DEC_POS ((POS).bytepos); \ + (POS).bytepos -= prev_char_len ((POS).bytepos); \ else \ --(POS).bytepos; \ } \ @@ -369,7 +369,7 @@ enum glyph_type /* Glyph describes a character. */ CHAR_GLYPH, - /* Glyph describes a static composition. */ + /* Glyph describes a static or automatic composition. */ COMPOSITE_GLYPH, /* Glyph describes a glyphless character. */ @@ -1693,12 +1693,17 @@ struct face int fontset; /* Non-zero means characters in this face have a box of that - thickness around them. If this value is negative, its absolute - value indicates the thickness, and the horizontal (top and - bottom) borders of box are drawn inside of the character glyphs' - area. The vertical (left and right) borders of the box are drawn - in the same way as when this value is positive. */ - int box_line_width; + thickness around them. Vertical (left and right) and horizontal + (top and bottom) borders size can be set separatedly using an + associated list of two ints in the form + (vertical_size . horizontal_size). In case one of the value is + negative, its absolute value indicates the thickness, and the + borders of box are drawn inside of the character glyphs' area + potentially over the glyph itself but the glyph drawing size is + not increase. If a (signed) int N is use instead of a list, it + is the same as setting ( abs(N) . N ) values. */ + int box_vertical_line_width; + int box_horizontal_line_width; /* Type of box drawn. A value of FACE_NO_BOX means no box is drawn around text in this face. A value of FACE_SIMPLE_BOX means a box @@ -1850,20 +1855,6 @@ struct face_cache bool_bf menu_face_changed_p : 1; }; -/* Return a non-null pointer to the cached face with ID on frame F. */ - -#define FACE_FROM_ID(F, ID) \ - (eassert (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used)), \ - FRAME_FACE_CACHE (F)->faces_by_id[ID]) - -/* Return a pointer to the face with ID on frame F, or null if such a - face doesn't exist. */ - -#define FACE_FROM_ID_OR_NULL(F, ID) \ - (UNSIGNED_CMP (ID, <, FRAME_FACE_CACHE (F)->used) \ - ? FRAME_FACE_CACHE (F)->faces_by_id[ID] \ - : NULL) - #define FACE_EXTENSIBLE_P(F) \ (!NILP (F->lface[LFACE_EXTEND_INDEX])) @@ -2782,7 +2773,8 @@ struct it else \ produce_glyphs ((IT)); \ if ((IT)->glyph_row != NULL) \ - inhibit_free_realized_faces = true; \ + inhibit_free_realized_faces =true; \ + reset_box_start_end_flags ((IT)); \ } while (false) /* Bit-flags indicating what operation move_it_to should perform. */ @@ -3157,21 +3149,6 @@ struct image_cache ptrdiff_t refcount; }; - -/* A non-null pointer to the image with id ID on frame F. */ - -#define IMAGE_FROM_ID(F, ID) \ - (eassert (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used)), \ - FRAME_IMAGE_CACHE (F)->images[ID]) - -/* Value is a pointer to the image with id ID on frame F, or null if - no image with that id exists. */ - -#define IMAGE_OPT_FROM_ID(F, ID) \ - (UNSIGNED_CMP (ID, <, FRAME_IMAGE_CACHE (F)->used) \ - ? FRAME_IMAGE_CACHE (F)->images[ID] \ - : NULL) - /* Size of bucket vector of image caches. Should be prime. */ #define IMAGE_CACHE_BUCKETS_SIZE 1001 @@ -3537,6 +3514,8 @@ void update_face_from_frame_parameter (struct frame *, Lisp_Object, Lisp_Object); extern bool tty_defined_color (struct frame *, const char *, Emacs_Color *, bool, bool); +bool parse_color_spec (const char *, + unsigned short *, unsigned short *, unsigned short *); Lisp_Object tty_color_name (struct frame *, int); void clear_face_cache (bool); diff --git a/src/dispnew.c b/src/dispnew.c index 5b6fa51a563..1ae59e3ff2b 100644 --- a/src/dispnew.c +++ b/src/dispnew.c @@ -881,7 +881,7 @@ clear_glyph_row (struct glyph_row *row) enum { off = offsetof (struct glyph_row, used) }; /* Zero everything except pointers in `glyphs'. */ - memset (row->used, 0, sizeof *row - off); + memset ((char *) row + off, 0, sizeof *row - off); } diff --git a/src/editfns.c b/src/editfns.c index fe1feaf1e77..763d95bb8fa 100644 --- a/src/editfns.c +++ b/src/editfns.c @@ -162,20 +162,14 @@ DEFUN ("byte-to-string", Fbyte_to_string, Sbyte_to_string, 1, 1, 0, DEFUN ("string-to-char", Fstring_to_char, Sstring_to_char, 1, 1, 0, doc: /* Return the first character in STRING. */) - (register Lisp_Object string) + (Lisp_Object string) { - register Lisp_Object val; CHECK_STRING (string); - if (SCHARS (string)) - { - if (STRING_MULTIBYTE (string)) - XSETFASTINT (val, STRING_CHAR (SDATA (string))); - else - XSETFASTINT (val, SREF (string, 0)); - } - else - XSETFASTINT (val, 0); - return val; + + /* This returns zero if STRING is empty. */ + return make_fixnum (STRING_MULTIBYTE (string) + ? STRING_CHAR (SDATA (string)) + : SREF (string, 0)); } DEFUN ("point", Fpoint, Spoint, 0, 0, 0, @@ -725,18 +719,23 @@ boundaries, bind `inhibit-field-text-motion' to t. This function does not move point. */) (Lisp_Object n) { - ptrdiff_t charpos, bytepos; + ptrdiff_t charpos, bytepos, count; if (NILP (n)) - XSETFASTINT (n, 1); + count = 0; + else if (FIXNUMP (n)) + count = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n) - 1, BUF_BYTES_MAX); else - CHECK_FIXNUM (n); + { + CHECK_INTEGER (n); + count = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } - scan_newline_from_point (XFIXNUM (n) - 1, &charpos, &bytepos); + scan_newline_from_point (count, &charpos, &bytepos); /* Return END constrained to the current input field. */ return Fconstrain_to_field (make_fixnum (charpos), make_fixnum (PT), - XFIXNUM (n) != 1 ? Qt : Qnil, + count != 0 ? Qt : Qnil, Qt, Qnil); } @@ -763,11 +762,14 @@ This function does not move point. */) ptrdiff_t orig = PT; if (NILP (n)) - XSETFASTINT (n, 1); + clipped_n = 1; + else if (FIXNUMP (n)) + clipped_n = clip_to_bounds (-BUF_BYTES_MAX, XFIXNUM (n), BUF_BYTES_MAX); else - CHECK_FIXNUM (n); - - clipped_n = clip_to_bounds (PTRDIFF_MIN + 1, XFIXNUM (n), PTRDIFF_MAX); + { + CHECK_INTEGER (n); + clipped_n = NILP (Fnatnump (n)) ? -BUF_BYTES_MAX : BUF_BYTES_MAX; + } end_pos = find_before_next_newline (orig, 0, clipped_n - (clipped_n <= 0), NULL); @@ -940,10 +942,10 @@ DEFUN ("position-bytes", Fposition_bytes, Sposition_bytes, 1, 1, 0, If POSITION is out of range, the value is nil. */) (Lisp_Object position) { - CHECK_FIXNUM_COERCE_MARKER (position); - if (XFIXNUM (position) < BEG || XFIXNUM (position) > Z) + EMACS_INT pos = fix_position (position); + if (! (BEG <= pos && pos <= Z)) return Qnil; - return make_fixnum (CHAR_TO_BYTE (XFIXNUM (position))); + return make_fixnum (CHAR_TO_BYTE (pos)); } DEFUN ("byte-to-position", Fbyte_to_position, Sbyte_to_position, 1, 1, 0, @@ -991,7 +993,7 @@ At the beginning of the buffer or accessible region, return 0. */) else if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) { ptrdiff_t pos = PT_BYTE; - DEC_POS (pos); + pos -= prev_char_len (pos); XSETFASTINT (temp, FETCH_CHAR (pos)); } else @@ -1060,11 +1062,11 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (XFIXNUM (pos) < BEGV || XFIXNUM (pos) >= ZV) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p < ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } return make_fixnum (FETCH_CHAR (pos_byte)); @@ -1094,17 +1096,17 @@ If POS is out of range, the value is nil. */) } else { - CHECK_FIXNUM_COERCE_MARKER (pos); + EMACS_INT p = fix_position (pos); - if (XFIXNUM (pos) <= BEGV || XFIXNUM (pos) > ZV) + if (! (BEGV < p && p <= ZV)) return Qnil; - pos_byte = CHAR_TO_BYTE (XFIXNUM (pos)); + pos_byte = CHAR_TO_BYTE (p); } if (!NILP (BVAR (current_buffer, enable_multibyte_characters))) { - DEC_POS (pos_byte); + pos_byte -= prev_char_len (pos_byte); XSETFASTINT (val, FETCH_CHAR (pos_byte)); } else @@ -1262,14 +1264,17 @@ name, or nil if there is no such user. */) if (q) { Lisp_Object login = Fuser_login_name (INT_TO_INTEGER (pw->pw_uid)); - USE_SAFE_ALLOCA; - char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); - memcpy (r, p, q - p); - char *s = lispstpcpy (&r[q - p], login); - r[q - p] = upcase ((unsigned char) r[q - p]); - strcpy (s, q + 1); - full = build_string (r); - SAFE_FREE (); + if (!NILP (login)) + { + USE_SAFE_ALLOCA; + char *r = SAFE_ALLOCA (strlen (p) + SBYTES (login) + 1); + memcpy (r, p, q - p); + char *s = lispstpcpy (&r[q - p], login); + r[q - p] = upcase ((unsigned char) r[q - p]); + strcpy (s, q + 1); + full = build_string (r); + SAFE_FREE (); + } } #endif /* AMPERSAND_FULL_NAME */ @@ -1538,7 +1543,7 @@ from adjoining text, if those properties are sticky. */) make_uninit_string, which can cause the buffer arena to be compacted. make_string has no way of knowing that the data has been moved, and thus copies the wrong data into the string. This - doesn't effect most of the other users of make_string, so it should + doesn't affect most of the other users of make_string, so it should be left as is. But we should use this function when conjuring buffer substrings. */ @@ -1715,21 +1720,8 @@ using `string-make-multibyte' or `string-make-unibyte', which see. */) if (!BUFFER_LIVE_P (bp)) error ("Selecting deleted buffer"); - if (NILP (start)) - b = BUF_BEGV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - if (NILP (end)) - e = BUF_ZV (bp); - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BUF_BEGV (bp); + e = !NILP (end) ? fix_position (end) : BUF_ZV (bp); if (b > e) temp = b, b = e, e = temp; @@ -1783,21 +1775,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start1)) - begp1 = BUF_BEGV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (start1); - begp1 = XFIXNUM (start1); - } - if (NILP (end1)) - endp1 = BUF_ZV (bp1); - else - { - CHECK_FIXNUM_COERCE_MARKER (end1); - endp1 = XFIXNUM (end1); - } - + begp1 = !NILP (start1) ? fix_position (start1) : BUF_BEGV (bp1); + endp1 = !NILP (end1) ? fix_position (end1) : BUF_ZV (bp1); if (begp1 > endp1) temp = begp1, begp1 = endp1, endp1 = temp; @@ -1821,21 +1800,8 @@ determines whether case is significant or ignored. */) error ("Selecting deleted buffer"); } - if (NILP (start2)) - begp2 = BUF_BEGV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (start2); - begp2 = XFIXNUM (start2); - } - if (NILP (end2)) - endp2 = BUF_ZV (bp2); - else - { - CHECK_FIXNUM_COERCE_MARKER (end2); - endp2 = XFIXNUM (end2); - } - + begp2 = !NILP (start2) ? fix_position (start2) : BUF_BEGV (bp2); + endp2 = !NILP (end2) ? fix_position (end2) : BUF_ZV (bp2); if (begp2 > endp2) temp = begp2, begp2 = endp2, endp2 = temp; @@ -1858,26 +1824,24 @@ determines whether case is significant or ignored. */) if (! NILP (BVAR (bp1, enable_multibyte_characters))) { c1 = BUF_FETCH_MULTIBYTE_CHAR (bp1, i1_byte); - BUF_INC_POS (bp1, i1_byte); + i1_byte += buf_next_char_len (bp1, i1_byte); i1++; } else { - c1 = BUF_FETCH_BYTE (bp1, i1); - MAKE_CHAR_MULTIBYTE (c1); + c1 = make_char_multibyte (BUF_FETCH_BYTE (bp1, i1)); i1++; } if (! NILP (BVAR (bp2, enable_multibyte_characters))) { c2 = BUF_FETCH_MULTIBYTE_CHAR (bp2, i2_byte); - BUF_INC_POS (bp2, i2_byte); + i2_byte += buf_next_char_len (bp2, i2_byte); i2++; } else { - c2 = BUF_FETCH_BYTE (bp2, i2); - MAKE_CHAR_MULTIBYTE (c2); + c2 = make_char_multibyte (BUF_FETCH_BYTE (bp2, i2)); i2++; } @@ -2332,7 +2296,7 @@ Both characters must have the same length of multi-byte form. */) } p = BYTE_POS_ADDR (pos_byte); if (multibyte_p) - INC_POS (pos_byte_next); + pos_byte_next += next_char_len (pos_byte_next); else ++pos_byte_next; if (pos_byte_next - pos_byte == len @@ -2393,7 +2357,7 @@ Both characters must have the same length of multi-byte form. */) decrease it now. */ pos--; else - INC_POS (pos_byte_next); + pos_byte_next += next_char_len (pos_byte_next); if (! NILP (noundo)) bset_undo_list (current_buffer, tem); @@ -2470,7 +2434,7 @@ check_translation (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t end, memcpy (bufalloc, buf, sizeof initial_buf); buf = bufalloc; } - buf[buf_used++] = STRING_CHAR_AND_LENGTH (p, len1); + buf[buf_used++] = string_char_and_length (p, &len1); pos_byte += len1; } if (XFIXNUM (AREF (elt, i)) != buf[i]) @@ -2529,13 +2493,13 @@ It returns the number of characters changed. */) int len, oc; if (multibyte) - oc = STRING_CHAR_AND_LENGTH (p, len); + oc = string_char_and_length (p, &len); else oc = *p, len = 1; if (oc < translatable_chars) { int nc; /* New character. */ - int str_len; + int str_len UNINIT; Lisp_Object val; if (STRINGP (table)) @@ -2546,7 +2510,7 @@ It returns the number of characters changed. */) if (string_multibyte) { str = tt + string_char_to_byte (table, oc); - nc = STRING_CHAR_AND_LENGTH (str, str_len); + nc = string_char_and_length (str, &str_len); } else { @@ -2689,29 +2653,27 @@ See also `save-restriction'. When calling from Lisp, pass two arguments START and END: positions (integers or markers) bounding the text that should remain visible. */) - (register Lisp_Object start, Lisp_Object end) + (Lisp_Object start, Lisp_Object end) { - CHECK_FIXNUM_COERCE_MARKER (start); - CHECK_FIXNUM_COERCE_MARKER (end); + EMACS_INT s = fix_position (start), e = fix_position (end); - if (XFIXNUM (start) > XFIXNUM (end)) + if (e < s) { - Lisp_Object tem; - tem = start; start = end; end = tem; + EMACS_INT tem = s; s = e; e = tem; } - if (!(BEG <= XFIXNUM (start) && XFIXNUM (start) <= XFIXNUM (end) && XFIXNUM (end) <= Z)) + if (!(BEG <= s && s <= e && e <= Z)) args_out_of_range (start, end); - if (BEGV != XFIXNAT (start) || ZV != XFIXNAT (end)) + if (BEGV != s || ZV != e) current_buffer->clip_changed = 1; - SET_BUF_BEGV (current_buffer, XFIXNAT (start)); - SET_BUF_ZV (current_buffer, XFIXNAT (end)); - if (PT < XFIXNAT (start)) - SET_PT (XFIXNAT (start)); - if (PT > XFIXNAT (end)) - SET_PT (XFIXNAT (end)); + SET_BUF_BEGV (current_buffer, s); + SET_BUF_ZV (current_buffer, e); + if (PT < s) + SET_PT (s); + if (e < PT) + SET_PT (e); /* Changing the buffer bounds invalidates any recorded current column. */ invalidate_current_column (); return Qnil; diff --git a/src/emacs-module.c b/src/emacs-module.c index 911b82b8a1a..ac9ac824b7b 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -78,6 +78,7 @@ To add a new module function, proceed as follows: #include "emacs-module.h" #include <stdarg.h> +#include <stdbool.h> #include <stddef.h> #include <stdint.h> #include <stdlib.h> @@ -88,6 +89,7 @@ To add a new module function, proceed as follows: #include "dynlib.h" #include "coding.h" #include "keyboard.h" +#include "process.h" #include "syssignal.h" #include "sysstdio.h" #include "thread.h" @@ -122,12 +124,6 @@ To add a new module function, proceed as follows: /* Function prototype for the module init function. */ typedef int (*emacs_init_function) (struct emacs_runtime *); -/* Function prototype for module user-pointer finalizers. These - should not throw C++ exceptions, so emacs-module.h declares the - corresponding interfaces with EMACS_NOEXCEPT. There is only C code - in this module, though, so this constraint is not enforced here. */ -typedef void (*emacs_finalizer_function) (void *); - /* Memory management. */ @@ -159,11 +155,11 @@ struct emacs_value_frame /* A structure that holds an initial frame (so that the first local values require no dynamic allocation) and keeps track of the current frame. */ -static struct emacs_value_storage +struct emacs_value_storage { struct emacs_value_frame initial; struct emacs_value_frame *current; -} global_storage; +}; /* Private runtime and environment members. */ @@ -194,7 +190,7 @@ struct emacs_runtime_private /* Forward declarations. */ static Lisp_Object value_to_lisp (emacs_value); -static emacs_value allocate_emacs_value (emacs_env *, struct emacs_value_storage *, Lisp_Object); +static emacs_value allocate_emacs_value (emacs_env *, Lisp_Object); static emacs_value lisp_to_value (emacs_env *, Lisp_Object); static enum emacs_funcall_exit module_non_local_exit_check (emacs_env *); static void module_assert_thread (void); @@ -219,6 +215,25 @@ static bool value_storage_contains_p (const struct emacs_value_storage *, static bool module_assertions = false; + +/* Small helper functions. */ + +/* Interprets the string at STR with length LEN as UTF-8 string. + Signals an error if it's not a valid UTF-8 string. */ + +static Lisp_Object +module_decode_utf_8 (const char *str, ptrdiff_t len) +{ + /* We set HANDLE-8-BIT and HANDLE-OVER-UNI to nil to signal an error + if the argument is not a valid UTF-8 string. While it isn't + documented how make_string and make_function behave in this case, + signaling an error is the most defensive and obvious reaction. */ + Lisp_Object s = decode_string_utf_8 (Qnil, str, len, Qnil, false, Qnil, Qnil); + CHECK_TYPE (!NILP (s), Qutf_8_string_p, make_string_from_utf8 (str, len)); + return s; +} + + /* Convenience macros for non-local exit handling. */ /* FIXME: The following implementation for non-local exit handling @@ -234,7 +249,7 @@ static bool module_assertions = false; of `internal_condition_case' etc., and to avoid worrying about passing information to the handler functions. */ -#if !__has_attribute (cleanup) +#if !HAS_ATTRIBUTE (cleanup) #error "__attribute__ ((cleanup)) not supported by this compiler; try GCC" #endif @@ -333,6 +348,12 @@ static bool module_assertions = false; MODULE_HANDLE_NONLOCAL_EXIT (error_retval) static void +CHECK_MODULE_FUNCTION (Lisp_Object obj) +{ + CHECK_TYPE (MODULE_FUNCTIONP (obj), Qmodule_function_p, obj); +} + +static void CHECK_USER_PTR (Lisp_Object obj) { CHECK_TYPE (USER_PTRP (obj), Quser_ptrp, obj); @@ -343,73 +364,125 @@ CHECK_USER_PTR (Lisp_Object obj) the Emacs main thread. */ static emacs_env * -module_get_environment (struct emacs_runtime *ert) +module_get_environment (struct emacs_runtime *runtime) { module_assert_thread (); - module_assert_runtime (ert); - return ert->private_members->env; + module_assert_runtime (runtime); + return runtime->private_members->env; } /* To make global refs (GC-protected global values) keep a hash that - maps global Lisp objects to reference counts. */ + maps global Lisp objects to 'struct module_global_reference' + objects. We store the 'emacs_value' in the hash table so that it + is automatically garbage-collected (Bug#42482). */ static Lisp_Object Vmodule_refs_hash; +/* Pseudovector type for global references. The pseudovector tag is + PVEC_OTHER since these values are never printed and don't need to + be special-cased for garbage collection. */ + +struct module_global_reference { + /* Pseudovector header, must come first. */ + union vectorlike_header header; + + /* Holds the emacs_value for the object. The Lisp_Object stored + therein must be the same as the hash key. */ + struct emacs_value_tag value; + + /* Reference count, always positive. */ + ptrdiff_t refcount; +}; + +static struct module_global_reference * +XMODULE_GLOBAL_REFERENCE (Lisp_Object o) +{ + eassert (PSEUDOVECTORP (o, PVEC_OTHER)); + return XUNTAG (o, Lisp_Vectorlike, struct module_global_reference); +} + +/* Returns whether V is a global reference. Only used to check module + assertions. If V is not a global reference, increment *N by the + number of global references (for debugging output). */ + +static bool +module_global_reference_p (emacs_value v, ptrdiff_t *n) +{ + struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); + /* Note that we can't use `hash_lookup' because V might be a local + reference that's identical to some global reference. */ + for (ptrdiff_t i = 0; i < HASH_TABLE_SIZE (h); ++i) + { + if (!EQ (HASH_KEY (h, i), Qunbound) + && &XMODULE_GLOBAL_REFERENCE (HASH_VALUE (h, i))->value == v) + return true; + } + /* Only used for debugging, so we don't care about overflow, just + make sure the operation is defined. */ + INT_ADD_WRAPV (*n, h->count, n); + return false; +} + static emacs_value -module_make_global_ref (emacs_env *env, emacs_value ref) +module_make_global_ref (emacs_env *env, emacs_value value) { MODULE_FUNCTION_BEGIN (NULL); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object new_obj = value_to_lisp (ref), hashcode; + Lisp_Object new_obj = value_to_lisp (value), hashcode; ptrdiff_t i = hash_lookup (h, new_obj, &hashcode); + /* Note: This approach requires the garbage collector to never move + objects. */ + if (i >= 0) { Lisp_Object value = HASH_VALUE (h, i); - EMACS_INT refcount = XFIXNAT (value) + 1; - if (MOST_POSITIVE_FIXNUM < refcount) + struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value); + bool overflow = INT_ADD_WRAPV (ref->refcount, 1, &ref->refcount); + if (overflow) overflow_error (); - value = make_fixed_natnum (refcount); - set_hash_value_slot (h, i, value); + return &ref->value; } else { - hash_put (h, new_obj, make_fixed_natnum (1), hashcode); + struct module_global_reference *ref + = ALLOCATE_PLAIN_PSEUDOVECTOR (struct module_global_reference, + PVEC_OTHER); + ref->value.v = new_obj; + ref->refcount = 1; + Lisp_Object value; + XSETPSEUDOVECTOR (value, ref, PVEC_OTHER); + hash_put (h, new_obj, value, hashcode); + return &ref->value; } - - return allocate_emacs_value (env, &global_storage, new_obj); } static void -module_free_global_ref (emacs_env *env, emacs_value ref) +module_free_global_ref (emacs_env *env, emacs_value global_value) { /* TODO: This probably never signals. */ /* FIXME: Wait a minute. Shouldn't this function report an error if the hash lookup fails? */ MODULE_FUNCTION_BEGIN (); struct Lisp_Hash_Table *h = XHASH_TABLE (Vmodule_refs_hash); - Lisp_Object obj = value_to_lisp (ref); + Lisp_Object obj = value_to_lisp (global_value); ptrdiff_t i = hash_lookup (h, obj, NULL); - if (i >= 0) + if (module_assertions) { - EMACS_INT refcount = XFIXNAT (HASH_VALUE (h, i)) - 1; - if (refcount > 0) - set_hash_value_slot (h, i, make_fixed_natnum (refcount)); - else - { - eassert (refcount == 0); - hash_remove_from_table (h, obj); - } + ptrdiff_t n = 0; + if (! module_global_reference_p (global_value, &n)) + module_abort ("Global value was not found in list of %"pD"d globals", + n); } - if (module_assertions) + if (i >= 0) { - ptrdiff_t count = 0; - if (value_storage_contains_p (&global_storage, ref, &count)) - return; - module_abort ("Global value was not found in list of %"pD"d globals", - count); + Lisp_Object value = HASH_VALUE (h, i); + struct module_global_reference *ref = XMODULE_GLOBAL_REFERENCE (value); + eassert (0 < ref->refcount); + if (--ref->refcount == 0) + hash_remove_from_table (h, obj); } } @@ -430,14 +503,15 @@ module_non_local_exit_clear (emacs_env *env) } static enum emacs_funcall_exit -module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) +module_non_local_exit_get (emacs_env *env, + emacs_value *symbol, emacs_value *data) { module_assert_thread (); module_assert_env (env); struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) { - *sym = &p->non_local_exit_symbol; + *symbol = &p->non_local_exit_symbol; *data = &p->non_local_exit_data; } return p->pending_non_local_exit; @@ -445,12 +519,13 @@ module_non_local_exit_get (emacs_env *env, emacs_value *sym, emacs_value *data) /* Like for `signal', DATA must be a list. */ static void -module_non_local_exit_signal (emacs_env *env, emacs_value sym, emacs_value data) +module_non_local_exit_signal (emacs_env *env, + emacs_value symbol, emacs_value data) { module_assert_thread (); module_assert_env (env); if (module_non_local_exit_check (env) == emacs_funcall_exit_return) - module_non_local_exit_signal_1 (env, value_to_lisp (sym), + module_non_local_exit_signal_1 (env, value_to_lisp (symbol), value_to_lisp (data)); } @@ -464,10 +539,6 @@ module_non_local_exit_throw (emacs_env *env, emacs_value tag, emacs_value value) value_to_lisp (value)); } -/* Function prototype for the module Lisp functions. */ -typedef emacs_value (*emacs_subr) (emacs_env *, ptrdiff_t, - emacs_value [], void *); - /* Module function. */ /* A function environment is an auxiliary structure returned by @@ -484,8 +555,9 @@ struct Lisp_Module_Function /* Fields ignored by GC. */ ptrdiff_t min_arity, max_arity; - emacs_subr subr; + emacs_function subr; void *data; + emacs_finalizer finalizer; } GCALIGNED_STRUCT; static struct Lisp_Module_Function * @@ -503,8 +575,7 @@ allocate_module_function (void) static emacs_value module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_subr subr, const char *documentation, - void *data) + emacs_function func, const char *docstring, void *data) { MODULE_FUNCTION_BEGIN (NULL); @@ -518,11 +589,13 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, struct Lisp_Module_Function *function = allocate_module_function (); function->min_arity = min_arity; function->max_arity = max_arity; - function->subr = subr; + function->subr = func; function->data = data; + function->finalizer = NULL; - if (documentation) - function->documentation = build_string_from_utf8 (documentation); + if (docstring) + function->documentation + = module_decode_utf_8 (docstring, strlen (docstring)); Lisp_Object result; XSET_MODULE_FUNCTION (result, function); @@ -531,9 +604,35 @@ module_make_function (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, return lisp_to_value (env, result); } +static emacs_finalizer +module_get_function_finalizer (emacs_env *env, emacs_value arg) +{ + MODULE_FUNCTION_BEGIN (NULL); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + return XMODULE_FUNCTION (lisp)->finalizer; +} + +static void +module_set_function_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) +{ + MODULE_FUNCTION_BEGIN (); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_MODULE_FUNCTION (lisp); + XMODULE_FUNCTION (lisp)->finalizer = fin; +} + +void +module_finalize_function (const struct Lisp_Module_Function *func) +{ + if (func->finalizer != NULL) + func->finalizer (func->data); +} + static emacs_value -module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, - emacs_value args[]) +module_funcall (emacs_env *env, emacs_value func, ptrdiff_t nargs, + emacs_value *args) { MODULE_FUNCTION_BEGIN (NULL); @@ -545,7 +644,7 @@ module_funcall (emacs_env *env, emacs_value fun, ptrdiff_t nargs, if (INT_ADD_WRAPV (nargs, 1, &nargs1)) overflow_error (); SAFE_ALLOCA_LISP (newargs, nargs1); - newargs[0] = value_to_lisp (fun); + newargs[0] = value_to_lisp (func); for (ptrdiff_t i = 0; i < nargs; i++) newargs[1 + i] = value_to_lisp (args[i]); emacs_value result = lisp_to_value (env, Ffuncall (nargs1, newargs)); @@ -561,17 +660,17 @@ module_intern (emacs_env *env, const char *name) } static emacs_value -module_type_of (emacs_env *env, emacs_value value) +module_type_of (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - return lisp_to_value (env, Ftype_of (value_to_lisp (value))); + return lisp_to_value (env, Ftype_of (value_to_lisp (arg))); } static bool -module_is_not_nil (emacs_env *env, emacs_value value) +module_is_not_nil (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN_NO_CATCH (false); - return ! NILP (value_to_lisp (value)); + return ! NILP (value_to_lisp (arg)); } static bool @@ -582,14 +681,14 @@ module_eq (emacs_env *env, emacs_value a, emacs_value b) } static intmax_t -module_extract_integer (emacs_env *env, emacs_value n) +module_extract_integer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object l = value_to_lisp (n); - CHECK_INTEGER (l); + Lisp_Object lisp = value_to_lisp (arg); + CHECK_INTEGER (lisp); intmax_t i; - if (! integer_to_intmax (l, &i)) - xsignal1 (Qoverflow_error, l); + if (! integer_to_intmax (lisp, &i)) + xsignal1 (Qoverflow_error, lisp); return i; } @@ -601,10 +700,10 @@ module_make_integer (emacs_env *env, intmax_t n) } static double -module_extract_float (emacs_env *env, emacs_value f) +module_extract_float (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lisp = value_to_lisp (f); + Lisp_Object lisp = value_to_lisp (arg); CHECK_TYPE (FLOATP (lisp), Qfloatp, lisp); return XFLOAT_DATA (lisp); } @@ -617,8 +716,8 @@ module_make_float (emacs_env *env, double d) } static bool -module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, - ptrdiff_t *length) +module_copy_string_contents (emacs_env *env, emacs_value value, char *buf, + ptrdiff_t *len) { MODULE_FUNCTION_BEGIN (false); Lisp_Object lisp_str = value_to_lisp (value); @@ -642,77 +741,77 @@ module_copy_string_contents (emacs_env *env, emacs_value value, char *buffer, ptrdiff_t raw_size = SBYTES (lisp_str_utf8); ptrdiff_t required_buf_size = raw_size + 1; - if (buffer == NULL) + if (buf == NULL) { - *length = required_buf_size; + *len = required_buf_size; return true; } - if (*length < required_buf_size) + if (*len < required_buf_size) { - ptrdiff_t actual = *length; - *length = required_buf_size; + ptrdiff_t actual = *len; + *len = required_buf_size; args_out_of_range_3 (INT_TO_INTEGER (actual), INT_TO_INTEGER (required_buf_size), INT_TO_INTEGER (PTRDIFF_MAX)); } - *length = required_buf_size; - memcpy (buffer, SDATA (lisp_str_utf8), raw_size + 1); + *len = required_buf_size; + memcpy (buf, SDATA (lisp_str_utf8), raw_size + 1); return true; } static emacs_value -module_make_string (emacs_env *env, const char *str, ptrdiff_t length) +module_make_string (emacs_env *env, const char *str, ptrdiff_t len) { MODULE_FUNCTION_BEGIN (NULL); - if (! (0 <= length && length <= STRING_BYTES_BOUND)) + if (! (0 <= len && len <= STRING_BYTES_BOUND)) overflow_error (); - Lisp_Object lstr = make_string_from_utf8 (str, length); + Lisp_Object lstr = module_decode_utf_8 (str, len); return lisp_to_value (env, lstr); } static emacs_value -module_make_user_ptr (emacs_env *env, emacs_finalizer_function fin, void *ptr) +module_make_user_ptr (emacs_env *env, emacs_finalizer fin, void *ptr) { MODULE_FUNCTION_BEGIN (NULL); return lisp_to_value (env, make_user_ptr (fin, ptr)); } static void * -module_get_user_ptr (emacs_env *env, emacs_value uptr) +module_get_user_ptr (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->p; } static void -module_set_user_ptr (emacs_env *env, emacs_value uptr, void *ptr) +module_set_user_ptr (emacs_env *env, emacs_value arg, void *ptr) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->p = ptr; } -static emacs_finalizer_function -module_get_user_finalizer (emacs_env *env, emacs_value uptr) +static emacs_finalizer +module_get_user_finalizer (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); return XUSER_PTR (lisp)->finalizer; } static void -module_set_user_finalizer (emacs_env *env, emacs_value uptr, - emacs_finalizer_function fin) +module_set_user_finalizer (emacs_env *env, emacs_value arg, + emacs_finalizer fin) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lisp = value_to_lisp (uptr); + Lisp_Object lisp = value_to_lisp (arg); CHECK_USER_PTR (lisp); XUSER_PTR (lisp)->finalizer = fin; } @@ -727,30 +826,31 @@ check_vec_index (Lisp_Object lvec, ptrdiff_t i) } static void -module_vec_set (emacs_env *env, emacs_value vec, ptrdiff_t i, emacs_value val) +module_vec_set (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) { MODULE_FUNCTION_BEGIN (); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - ASET (lvec, i, value_to_lisp (val)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + ASET (lisp, index, value_to_lisp (value)); } static emacs_value -module_vec_get (emacs_env *env, emacs_value vec, ptrdiff_t i) +module_vec_get (emacs_env *env, emacs_value vector, ptrdiff_t index) { MODULE_FUNCTION_BEGIN (NULL); - Lisp_Object lvec = value_to_lisp (vec); - check_vec_index (lvec, i); - return lisp_to_value (env, AREF (lvec, i)); + Lisp_Object lisp = value_to_lisp (vector); + check_vec_index (lisp, index); + return lisp_to_value (env, AREF (lisp, index)); } static ptrdiff_t -module_vec_size (emacs_env *env, emacs_value vec) +module_vec_size (emacs_env *env, emacs_value vector) { MODULE_FUNCTION_BEGIN (0); - Lisp_Object lvec = value_to_lisp (vec); - CHECK_VECTOR (lvec); - return ASIZE (lvec); + Lisp_Object lisp = value_to_lisp (vector); + CHECK_VECTOR (lisp); + return ASIZE (lisp); } /* This function should return true if and only if maybe_quit would @@ -771,10 +871,10 @@ module_process_input (emacs_env *env) } static struct timespec -module_extract_time (emacs_env *env, emacs_value value) +module_extract_time (emacs_env *env, emacs_value arg) { MODULE_FUNCTION_BEGIN ((struct timespec) {0}); - return lisp_time_argument (value_to_lisp (value)); + return lisp_time_argument (value_to_lisp (arg)); } static emacs_value @@ -931,6 +1031,13 @@ module_make_big_integer (emacs_env *env, int sign, return lisp_to_value (env, make_integer_mpz ()); } +static int +module_open_channel (emacs_env *env, emacs_value pipe_process) +{ + MODULE_FUNCTION_BEGIN (-1); + return open_channel_for_module (value_to_lisp (pipe_process)); +} + /* Subroutines. */ @@ -1072,6 +1179,12 @@ module_function_address (const struct Lisp_Module_Function *function) return (module_funcptr) function->subr; } +void * +module_function_data (const struct Lisp_Module_Function *function) +{ + return function->data; +} + /* Helper functions. */ @@ -1088,14 +1201,14 @@ module_assert_thread (void) } static void -module_assert_runtime (struct emacs_runtime *ert) +module_assert_runtime (struct emacs_runtime *runtime) { if (! module_assertions) return; ptrdiff_t count = 0; for (Lisp_Object tail = Vmodule_runtimes; CONSP (tail); tail = XCDR (tail)) { - if (xmint_pointer (XCAR (tail)) == ert) + if (xmint_pointer (XCAR (tail)) == runtime) return; ++count; } @@ -1190,7 +1303,7 @@ value_to_lisp (emacs_value v) ++num_environments; } /* Also check global values. */ - if (value_storage_contains_p (&global_storage, v, &num_values)) + if (module_global_reference_p (v, &num_values)) goto ok; module_abort (("Emacs value not found in %"pD"d values " "of %"pD"d environments"), @@ -1208,7 +1321,7 @@ lisp_to_value (emacs_env *env, Lisp_Object o) struct emacs_env_private *p = env->private_members; if (p->pending_non_local_exit != emacs_funcall_exit_return) return NULL; - return allocate_emacs_value (env, &p->storage, o); + return allocate_emacs_value (env, o); } /* Must be called for each frame before it can be used for allocation. */ @@ -1245,9 +1358,9 @@ finalize_storage (struct emacs_value_storage *storage) /* Allocate a new value from STORAGE and stores OBJ in it. Return NULL if allocation fails and use ENV for non local exit reporting. */ static emacs_value -allocate_emacs_value (emacs_env *env, struct emacs_value_storage *storage, - Lisp_Object obj) +allocate_emacs_value (emacs_env *env, Lisp_Object obj) { + struct emacs_value_storage *storage = &env->private_members->storage; eassert (storage->current); eassert (storage->current->offset < value_frame_size); eassert (! storage->current->next); @@ -1337,6 +1450,9 @@ initialize_environment (emacs_env *env, struct emacs_env_private *priv) env->make_time = module_make_time; env->extract_big_integer = module_extract_big_integer; env->make_big_integer = module_make_big_integer; + env->get_function_finalizer = module_get_function_finalizer; + env->set_function_finalizer = module_set_function_finalizer; + env->open_channel = module_open_channel; Vmodule_environments = Fcons (make_mint_ptr (env), Vmodule_environments); return env; } @@ -1404,10 +1520,7 @@ module_handle_nonlocal_exit (emacs_env *env, enum nonlocal_exit type, void init_module_assertions (bool enable) { - /* If enabling module assertions, use a hidden environment for - storing the globals. This environment is never freed. */ module_assertions = enable; - initialize_storage (&global_storage); } /* Return whether STORAGE contains VALUE. Used to check module diff --git a/src/emacs-module.h.in b/src/emacs-module.h.in index 898021dc5e6..6a39d507c84 100644 --- a/src/emacs-module.h.in +++ b/src/emacs-module.h.in @@ -42,10 +42,20 @@ information how to write modules and use this header file. # define EMACS_NOEXCEPT #endif -#ifdef __has_attribute -#if __has_attribute(__nonnull__) -# define EMACS_ATTRIBUTE_NONNULL(...) __attribute__((__nonnull__(__VA_ARGS__))) +#if defined __cplusplus && __cplusplus >= 201703L +# define EMACS_NOEXCEPT_TYPEDEF noexcept +#else +# define EMACS_NOEXCEPT_TYPEDEF #endif + +#if 3 < __GNUC__ + (3 <= __GNUC_MINOR__) +# define EMACS_ATTRIBUTE_NONNULL(...) \ + __attribute__ ((__nonnull__ (__VA_ARGS__))) +#elif defined __has_attribute +# if __has_attribute (__nonnull__) +# define EMACS_ATTRIBUTE_NONNULL(...) \ + __attribute__ ((__nonnull__ (__VA_ARGS__))) +# endif #endif #ifndef EMACS_ATTRIBUTE_NONNULL # define EMACS_ATTRIBUTE_NONNULL(...) @@ -56,7 +66,7 @@ extern "C" { #endif /* Current environment. */ -typedef struct emacs_env_27 emacs_env; +typedef struct emacs_env_@emacs_major_version@ emacs_env; /* Opaque pointer representing an Emacs Lisp value. BEWARE: Do not assume NULL is a valid value! */ @@ -74,10 +84,25 @@ struct emacs_runtime struct emacs_runtime_private *private_members; /* Return an environment pointer. */ - emacs_env *(*get_environment) (struct emacs_runtime *ert) - EMACS_ATTRIBUTE_NONNULL(1); + emacs_env *(*get_environment) (struct emacs_runtime *runtime) + EMACS_ATTRIBUTE_NONNULL (1); }; +/* Type aliases for function pointer types used in the module API. + Note that we don't use these aliases directly in the API to be able + to mark the function arguments as 'noexcept' before C++20. + However, users can use them if they want. */ + +/* Function prototype for the module Lisp functions. These must not + throw C++ exceptions. */ +typedef emacs_value (*emacs_function) (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, + void *data) + EMACS_NOEXCEPT_TYPEDEF EMACS_ATTRIBUTE_NONNULL (1); + +/* Function prototype for module user-pointer and function finalizers. + These must not throw C++ exceptions. */ +typedef void (*emacs_finalizer) (void *data) EMACS_NOEXCEPT_TYPEDEF; /* Possible Emacs function call outcomes. */ enum emacs_funcall_exit @@ -131,10 +156,21 @@ struct emacs_env_27 @module_env_snippet_27@ }; +struct emacs_env_28 +{ +@module_env_snippet_25@ + +@module_env_snippet_26@ + +@module_env_snippet_27@ + +@module_env_snippet_28@ +}; + /* Every module should define a function as follows. */ -extern int emacs_module_init (struct emacs_runtime *ert) +extern int emacs_module_init (struct emacs_runtime *runtime) EMACS_NOEXCEPT - EMACS_ATTRIBUTE_NONNULL(1); + EMACS_ATTRIBUTE_NONNULL (1); #ifdef __cplusplus } diff --git a/src/emacs.c b/src/emacs.c index 1dcf1958912..8a6bb3ad228 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -938,7 +938,6 @@ main (int argc, char **argv) for pointers. */ void *stack_bottom_variable; - bool do_initial_setlocale; bool no_loadup = false; char *junk = 0; char *dname_arg = 0; @@ -1243,19 +1242,21 @@ main (int argc, char **argv) set_binary_mode (STDOUT_FILENO, O_BINARY); #endif /* MSDOS */ - /* Skip initial setlocale if LC_ALL is "C", as it's not needed in that case. - The build procedure uses this while dumping, to ensure that the - dumped Emacs does not have its system locale tables initialized, - as that might cause screwups when the dumped Emacs starts up. */ - { - char *lc_all = getenv ("LC_ALL"); - do_initial_setlocale = ! lc_all || strcmp (lc_all, "C"); - } - - /* Set locale now, so that initial error messages are localized properly. - fixup_locale must wait until later, since it builds strings. */ - if (do_initial_setlocale) - setlocale (LC_ALL, ""); + /* Set locale, so that initial error messages are localized properly. + However, skip this if LC_ALL is "C", as it's not needed in that case. + Skipping helps if dumping with unexec, to ensure that the dumped + Emacs does not have its system locale tables initialized, as that + might cause screwups when the dumped Emacs starts up. */ + char *lc_all = getenv ("LC_ALL"); + if (! (lc_all && strcmp (lc_all, "C") == 0)) + { + #ifdef HAVE_NS + ns_pool = ns_alloc_autorelease_pool (); + ns_init_locale (); + #endif + setlocale (LC_ALL, ""); + fixup_locale (); + } text_quoting_flag = using_utf8 (); inhibit_window_system = 0; @@ -1584,14 +1585,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem init_alloc (); init_bignum (); init_threads (); - - if (do_initial_setlocale) - { - fixup_locale (); - Vsystem_messages_locale = Vprevious_system_messages_locale; - Vsystem_time_locale = Vprevious_system_time_locale; - } - init_eval (); init_atimer (); running_asynch_code = 0; @@ -1628,12 +1621,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem #endif #ifdef HAVE_NS - ns_pool = ns_alloc_autorelease_pool (); -#ifdef NS_IMPL_GNUSTEP - /* GNUstep stupidly resets our locale settings after we made them. */ - fixup_locale (); -#endif - if (!noninteractive) { #ifdef NS_IMPL_COCOA @@ -1743,11 +1730,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem globals_of_gfilenotify (); #endif -#ifdef HAVE_NS - /* Initialize the locale from user defaults. */ - ns_init_locale (); -#endif - /* Initialize and GC-protect Vinitial_environment and Vprocess_environment before set_initial_environment fills them in. */ @@ -1990,7 +1972,6 @@ Using an Emacs configured with --with-x-toolkit=lucid does not have this problem /* This calls putenv and so must precede init_process_emacs. */ init_timefns (); - /* This sets Voperating_system_release, which init_process_emacs uses. */ init_editfns (); /* These two call putenv. */ @@ -2627,25 +2608,25 @@ synchronize_locale (int category, Lisp_Object *plocale, Lisp_Object desired_loca if (! EQ (*plocale, desired_locale)) { *plocale = desired_locale; -#ifdef WINDOWSNT + char const *locale_string + = STRINGP (desired_locale) ? SSDATA (desired_locale) : ""; +# ifdef WINDOWSNT /* Changing categories like LC_TIME usually requires specifying an encoding suitable for the new locale, but MS-Windows's 'setlocale' will only switch the encoding when LC_ALL is specified. So we ignore CATEGORY, use LC_ALL instead, and then restore LC_NUMERIC to "C", so reading and printing numbers is unaffected. */ - setlocale (LC_ALL, (STRINGP (desired_locale) - ? SSDATA (desired_locale) - : "")); + setlocale (LC_ALL, locale_string); fixup_locale (); -#else /* !WINDOWSNT */ - setlocale (category, (STRINGP (desired_locale) - ? SSDATA (desired_locale) - : "")); -#endif /* !WINDOWSNT */ +# else /* !WINDOWSNT */ + setlocale (category, locale_string); +# endif /* !WINDOWSNT */ } } +static Lisp_Object Vprevious_system_time_locale; + /* Set system time locale to match Vsystem_time_locale, if possible. */ void synchronize_system_time_locale (void) @@ -2654,15 +2635,19 @@ synchronize_system_time_locale (void) Vsystem_time_locale); } +# ifdef LC_MESSAGES +static Lisp_Object Vprevious_system_messages_locale; +# endif + /* Set system messages locale to match Vsystem_messages_locale, if possible. */ void synchronize_system_messages_locale (void) { -#ifdef LC_MESSAGES +# ifdef LC_MESSAGES synchronize_locale (LC_MESSAGES, &Vprevious_system_messages_locale, Vsystem_messages_locale); -#endif +# endif } #endif /* HAVE_SETLOCALE */ @@ -2984,19 +2969,16 @@ build directory. */); DEFVAR_LISP ("system-messages-locale", Vsystem_messages_locale, doc: /* System locale for messages. */); Vsystem_messages_locale = Qnil; - - DEFVAR_LISP ("previous-system-messages-locale", - Vprevious_system_messages_locale, - doc: /* Most recently used system locale for messages. */); +#ifdef LC_MESSAGES Vprevious_system_messages_locale = Qnil; + staticpro (&Vprevious_system_messages_locale); +#endif DEFVAR_LISP ("system-time-locale", Vsystem_time_locale, doc: /* System locale for time. */); Vsystem_time_locale = Qnil; - - DEFVAR_LISP ("previous-system-time-locale", Vprevious_system_time_locale, - doc: /* Most recently used system locale for time. */); Vprevious_system_time_locale = Qnil; + staticpro (&Vprevious_system_time_locale); DEFVAR_LISP ("before-init-time", Vbefore_init_time, doc: /* Value of `current-time' before Emacs begins initialization. */); diff --git a/src/eval.c b/src/eval.c index 16c36fa284c..9daae92e55a 100644 --- a/src/eval.c +++ b/src/eval.c @@ -2905,6 +2905,21 @@ funcall_subr (struct Lisp_Subr *subr, ptrdiff_t numargs, Lisp_Object *args) } } +/* Call the compiled Lisp function FUN. If we have not yet read FUN's + bytecode string and constants vector, fetch them from the file first. */ + +static Lisp_Object +fetch_and_exec_byte_code (Lisp_Object fun, Lisp_Object syms_left, + ptrdiff_t nargs, Lisp_Object *args) +{ + if (CONSP (AREF (fun, COMPILED_BYTECODE))) + Ffetch_bytecode (fun); + return exec_byte_code (AREF (fun, COMPILED_BYTECODE), + AREF (fun, COMPILED_CONSTANTS), + AREF (fun, COMPILED_STACK_DEPTH), + syms_left, nargs, args); +} + static Lisp_Object apply_lambda (Lisp_Object fun, Lisp_Object args, ptrdiff_t count) { @@ -2969,9 +2984,6 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) /* A byte-code object with an integer args template means we @@ -2983,15 +2995,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, argument-binding code below instead (as do all interpreted functions, even lexically bound ones). */ { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - return exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - syms_left, - nargs, arg_vector); + return fetch_and_exec_byte_code (fun, syms_left, nargs, arg_vector); } lexenv = Qnil; } @@ -3060,16 +3064,7 @@ funcall_lambda (Lisp_Object fun, ptrdiff_t nargs, if (CONSP (fun)) val = Fprogn (XCDR (XCDR (fun))); else - { - /* If we have not actually read the bytecode string - and constants vector yet, fetch them from the file. */ - if (CONSP (AREF (fun, COMPILED_BYTECODE))) - Ffetch_bytecode (fun); - val = exec_byte_code (AREF (fun, COMPILED_BYTECODE), - AREF (fun, COMPILED_CONSTANTS), - AREF (fun, COMPILED_STACK_DEPTH), - Qnil, 0, 0); - } + val = fetch_and_exec_byte_code (fun, Qnil, 0, NULL); return unbind_to (count, val); } @@ -3154,9 +3149,6 @@ lambda_arity (Lisp_Object fun) } else if (COMPILEDP (fun)) { - ptrdiff_t size = PVSIZE (fun); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, fun); syms_left = AREF (fun, COMPILED_ARGLIST); if (FIXNUMP (syms_left)) return get_byte_code_arity (syms_left); @@ -3199,13 +3191,11 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, if (COMPILEDP (object)) { - ptrdiff_t size = PVSIZE (object); - if (size <= COMPILED_STACK_DEPTH) - xsignal1 (Qinvalid_function, object); if (CONSP (AREF (object, COMPILED_BYTECODE))) { tem = read_doc_string (AREF (object, COMPILED_BYTECODE)); - if (!CONSP (tem)) + if (! (CONSP (tem) && STRINGP (XCAR (tem)) + && VECTORP (XCDR (tem)))) { tem = AREF (object, COMPILED_BYTECODE); if (CONSP (tem) && STRINGP (XCAR (tem))) @@ -3213,7 +3203,19 @@ DEFUN ("fetch-bytecode", Ffetch_bytecode, Sfetch_bytecode, else error ("Invalid byte code"); } - ASET (object, COMPILED_BYTECODE, XCAR (tem)); + + Lisp_Object bytecode = XCAR (tem); + if (STRING_MULTIBYTE (bytecode)) + { + /* BYTECODE must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and now + such a byte-code string is loaded as multibyte with raw 8-bit + characters converted to multibyte form. Convert them back to + the original unibyte form. */ + bytecode = Fstring_as_unibyte (bytecode); + } + + ASET (object, COMPILED_BYTECODE, bytecode); ASET (object, COMPILED_CONSTANTS, XCDR (tem)); } } diff --git a/src/fileio.c b/src/fileio.c index 482f88627a5..37072d9b6bd 100644 --- a/src/fileio.c +++ b/src/fileio.c @@ -96,7 +96,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <acl.h> #include <allocator.h> #include <careadlinkat.h> -#include <dosname.h> +#include <filename.h> #include <fsusage.h> #include <stat-time.h> #include <tempname.h> @@ -1952,7 +1952,10 @@ barf_or_query_if_file_exists (Lisp_Object absname, bool known_to_exist, encoded_filename = ENCODE_FILE (absname); - if (! known_to_exist && lstat (SSDATA (encoded_filename), &statbuf) == 0) + if (! known_to_exist + && (emacs_fstatat (AT_FDCWD, SSDATA (encoded_filename), + &statbuf, AT_SYMLINK_NOFOLLOW) + == 0)) { if (S_ISDIR (statbuf.st_mode)) xsignal2 (Qfile_error, @@ -2028,7 +2031,7 @@ permissions. */) ptrdiff_t count = SPECPDL_INDEX (); Lisp_Object encoded_file, encoded_newname; #if HAVE_LIBSELINUX - security_context_t con; + char *con; int conlength = 0; #endif #ifdef WINDOWSNT @@ -2074,7 +2077,7 @@ permissions. */) report_file_error ("Copying permissions from", file); case -3: xsignal2 (Qfile_date_error, - build_string ("Resetting file times"), newname); + build_string ("Cannot set file date"), newname); case -4: report_file_error ("Copying permissions to", newname); } @@ -2250,9 +2253,8 @@ permissions. */) if (!NILP (keep_time)) { - struct timespec atime = get_stat_atime (&st); - struct timespec mtime = get_stat_mtime (&st); - if (set_file_times (ofd, SSDATA (encoded_newname), atime, mtime) != 0) + struct timespec ts[] = { get_stat_atime (&st), get_stat_mtime (&st) }; + if (futimens (ofd, ts) != 0) xsignal2 (Qfile_date_error, build_string ("Cannot set file date"), newname); } @@ -2555,7 +2557,9 @@ This is what happens in interactive use with M-x. */) bool dirp = !NILP (Fdirectory_name_p (file)); if (!dirp) { - if (lstat (SSDATA (encoded_file), &file_st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (encoded_file), + &file_st, AT_SYMLINK_NOFOLLOW) + != 0) report_file_error ("Renaming", list2 (file, newname)); dirp = S_ISDIR (file_st.st_mode) != 0; } @@ -2928,7 +2932,8 @@ file_directory_p (Lisp_Object file) #else # ifdef O_PATH /* Use O_PATH if available, as it avoids races and EOVERFLOW issues. */ - int fd = openat (AT_FDCWD, SSDATA (file), O_PATH | O_CLOEXEC | O_DIRECTORY); + int fd = emacs_openat (AT_FDCWD, SSDATA (file), + O_PATH | O_CLOEXEC | O_DIRECTORY, 0); if (0 <= fd) { emacs_close (fd); @@ -2939,9 +2944,9 @@ file_directory_p (Lisp_Object file) /* O_PATH is defined but evidently this Linux kernel predates 2.6.39. Fall back on generic POSIX code. */ # endif - /* Use file_accessible_directory_p, as it avoids stat EOVERFLOW + /* Use file_accessible_directory_p, as it avoids fstatat EOVERFLOW problems and could be cheaper. However, if it fails because FILE - is inaccessible, fall back on stat; if the latter fails with + is inaccessible, fall back on fstatat; if the latter fails with EOVERFLOW then FILE must have been a directory unless a race condition occurred (a problem hard to work around portably). */ if (file_accessible_directory_p (file)) @@ -2949,7 +2954,7 @@ file_directory_p (Lisp_Object file) if (errno != EACCES) return false; struct stat st; - if (stat (SSDATA (file), &st) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (file), &st, 0) != 0) return errno == EOVERFLOW; if (S_ISDIR (st.st_mode)) return true; @@ -3080,7 +3085,7 @@ See `file-symlink-p' to distinguish symlinks. */) Vw32_get_true_file_attributes = Qt; #endif - int stat_result = stat (SSDATA (absname), &st); + int stat_result = emacs_fstatat (AT_FDCWD, SSDATA (absname), &st, 0); #ifdef WINDOWSNT Vw32_get_true_file_attributes = true_attributes; @@ -3113,7 +3118,7 @@ or if SELinux is disabled, or if Emacs lacks SELinux support. */) #if HAVE_LIBSELINUX if (is_selinux_enabled ()) { - security_context_t con; + char *con; int conlength = lgetfilecon (SSDATA (ENCODE_FILE (absname)), &con); if (conlength > 0) { @@ -3158,7 +3163,7 @@ or if Emacs was not compiled with SELinux support. */) Lisp_Object role = CAR_SAFE (CDR_SAFE (context)); Lisp_Object type = CAR_SAFE (CDR_SAFE (CDR_SAFE (context))); Lisp_Object range = CAR_SAFE (CDR_SAFE (CDR_SAFE (CDR_SAFE (context)))); - security_context_t con; + char *con; bool fail; int conlength; context_t parsed_con; @@ -3326,50 +3331,60 @@ support. */) return Qnil; } -DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 1, 0, +static int +symlink_nofollow_flag (Lisp_Object flag) +{ + /* For now, treat all non-nil FLAGs like 'nofollow'. */ + return !NILP (flag) ? AT_SYMLINK_NOFOLLOW : 0; +} + +DEFUN ("file-modes", Ffile_modes, Sfile_modes, 1, 2, 0, doc: /* Return mode bits of file named FILENAME, as an integer. -Return nil if FILENAME does not exist. */) - (Lisp_Object filename) +Return nil if FILENAME does not exist. If optional FLAG is `nofollow', +do not follow FILENAME if it is a symbolic link. */) + (Lisp_Object filename, Lisp_Object flag) { struct stat st; + int nofollow = symlink_nofollow_flag (flag); Lisp_Object absname = expand_and_dir_to_file (filename); /* If the file name has special constructs in it, call the corresponding file name handler. */ Lisp_Object handler = Ffind_file_name_handler (absname, Qfile_modes); if (!NILP (handler)) - return call2 (handler, Qfile_modes, absname); + return call3 (handler, Qfile_modes, absname, flag); - if (stat (SSDATA (ENCODE_FILE (absname)), &st) != 0) + char *fname = SSDATA (ENCODE_FILE (absname)); + if (emacs_fstatat (AT_FDCWD, fname, &st, nofollow) != 0) return file_attribute_errno (absname, errno); return make_fixnum (st.st_mode & 07777); } -DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 2, +DEFUN ("set-file-modes", Fset_file_modes, Sset_file_modes, 2, 3, "(let ((file (read-file-name \"File: \"))) \ (list file (read-file-modes nil file)))", doc: /* Set mode bits of file named FILENAME to MODE (an integer). -Only the 12 low bits of MODE are used. +Only the 12 low bits of MODE are used. If optional FLAG is `nofollow', +do not follow FILENAME if it is a symbolic link. Interactively, mode bits are read by `read-file-modes', which accepts symbolic notation, like the `chmod' command from GNU Coreutils. */) - (Lisp_Object filename, Lisp_Object mode) + (Lisp_Object filename, Lisp_Object mode, Lisp_Object flag) { - Lisp_Object absname, encoded_absname; - Lisp_Object handler; - - absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); CHECK_FIXNUM (mode); + int nofollow = symlink_nofollow_flag (flag); + Lisp_Object absname = Fexpand_file_name (filename, + BVAR (current_buffer, directory)); /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qset_file_modes); + Lisp_Object handler = Ffind_file_name_handler (absname, Qset_file_modes); if (!NILP (handler)) - return call3 (handler, Qset_file_modes, absname, mode); - - encoded_absname = ENCODE_FILE (absname); + return call4 (handler, Qset_file_modes, absname, mode, flag); - if (chmod (SSDATA (encoded_absname), XFIXNUM (mode) & 07777) < 0) + char *fname = SSDATA (ENCODE_FILE (absname)); + mode_t imode = XFIXNUM (mode) & 07777; + if (fchmodat (AT_FDCWD, fname, imode, nofollow) != 0) report_file_error ("Doing chmod", absname); return Qnil; @@ -3414,39 +3429,41 @@ The value is an integer. */) } -DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 2, 0, +DEFUN ("set-file-times", Fset_file_times, Sset_file_times, 1, 3, 0, doc: /* Set times of file FILENAME to TIMESTAMP. -Set both access and modification times. -Return t on success, else nil. -Use the current time if TIMESTAMP is nil. TIMESTAMP is in the format of -`current-time'. */) - (Lisp_Object filename, Lisp_Object timestamp) +If optional FLAG is `nofollow', do not follow FILENAME if it is a +symbolic link. Set both access and modification times. Return t on +success, else nil. Use the current time if TIMESTAMP is nil. +TIMESTAMP is in the format of `current-time'. */) + (Lisp_Object filename, Lisp_Object timestamp, Lisp_Object flag) { - Lisp_Object absname, encoded_absname; - Lisp_Object handler; - struct timespec t = lisp_time_argument (timestamp); + int nofollow = symlink_nofollow_flag (flag); - absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)); + struct timespec ts[2]; + if (!NILP (timestamp)) + ts[0] = ts[1] = lisp_time_argument (timestamp); + else + ts[0].tv_nsec = ts[1].tv_nsec = UTIME_NOW; /* If the file name has special constructs in it, call the corresponding file name handler. */ - handler = Ffind_file_name_handler (absname, Qset_file_times); + Lisp_Object + absname = Fexpand_file_name (filename, BVAR (current_buffer, directory)), + handler = Ffind_file_name_handler (absname, Qset_file_times); if (!NILP (handler)) - return call3 (handler, Qset_file_times, absname, timestamp); + return call4 (handler, Qset_file_times, absname, timestamp, flag); - encoded_absname = ENCODE_FILE (absname); + Lisp_Object encoded_absname = ENCODE_FILE (absname); - { - if (set_file_times (-1, SSDATA (encoded_absname), t, t) != 0) - { + if (utimensat (AT_FDCWD, SSDATA (encoded_absname), ts, nofollow) != 0) + { #ifdef MSDOS - /* Setting times on a directory always fails. */ - if (file_directory_p (encoded_absname)) - return Qnil; + /* Setting times on a directory always fails. */ + if (file_directory_p (encoded_absname)) + return Qnil; #endif - report_file_error ("Setting file times", absname); - } - } + report_file_error ("Setting file times", absname); + } return Qt; } @@ -3486,7 +3503,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) return call3 (handler, Qfile_newer_than_file_p, absname1, absname2); int err1; - if (stat (SSDATA (ENCODE_FILE (absname1)), &st1) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname1)), &st1, 0) == 0) err1 = 0; else { @@ -3494,7 +3511,7 @@ otherwise, if FILE2 does not exist, the answer is t. */) if (err1 != EOVERFLOW) return file_attribute_errno (absname1, err1); } - if (stat (SSDATA (ENCODE_FILE (absname2)), &st2) != 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (absname2)), &st2, 0) != 0) { file_attribute_errno (absname2, errno); return Qt; @@ -3880,7 +3897,7 @@ by calling `format-decode', which see. */) if (end_offset < 0) buffer_overflow (); - /* The file size returned from stat may be zero, but data + /* The file size returned from fstat may be zero, but data may be readable nonetheless, for example when this is a file in the /proc filesystem. */ if (end_offset == 0) @@ -5625,7 +5642,7 @@ See Info node `(elisp)Modification Time' for more details. */) filename = ENCODE_FILE (BVAR (b, filename)); - mtime = (stat (SSDATA (filename), &st) == 0 + mtime = (emacs_fstatat (AT_FDCWD, SSDATA (filename), &st, 0) == 0 ? get_stat_mtime (&st) : time_error_value (errno)); if (timespec_cmp (mtime, b->modtime) == 0 @@ -5665,8 +5682,8 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) struct timespec mtime; if (FIXNUMP (time_flag)) { - CHECK_RANGED_INTEGER (time_flag, -1, 0); - mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - XFIXNUM (time_flag)); + int flag = check_integer_range (time_flag, -1, 0); + mtime = make_timespec (0, UNKNOWN_MODTIME_NSECS - flag); } else mtime = lisp_time_argument (time_flag); @@ -5689,7 +5706,8 @@ in `current-time' or an integer flag as returned by `visited-file-modtime'. */) /* The handler can find the file name the same way we did. */ return call2 (handler, Qset_visited_file_modtime, Qnil); - if (stat (SSDATA (ENCODE_FILE (filename)), &st) == 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (ENCODE_FILE (filename)), &st, 0) + == 0) { current_buffer->modtime = get_stat_mtime (&st); current_buffer->modtime_size = st.st_size; @@ -5728,12 +5746,14 @@ auto_save_1 (void) /* Get visited file's mode to become the auto save file's mode. */ if (! NILP (BVAR (current_buffer, filename))) { - if (stat (SSDATA (BVAR (current_buffer, filename)), &st) >= 0) + if (emacs_fstatat (AT_FDCWD, SSDATA (BVAR (current_buffer, filename)), + &st, 0) + == 0) /* But make sure we can overwrite it later! */ auto_save_mode_bits = (st.st_mode | 0600) & 0777; - else if (modes = Ffile_modes (BVAR (current_buffer, filename)), + else if (modes = Ffile_modes (BVAR (current_buffer, filename), Qnil), FIXNUMP (modes)) - /* Remote files don't cooperate with stat. */ + /* Remote files don't cooperate with fstatat. */ auto_save_mode_bits = (XFIXNUM (modes) | 0600) & 0777; } diff --git a/src/filelock.c b/src/filelock.c index b28f16e9b5a..ee46e0e3e00 100644 --- a/src/filelock.c +++ b/src/filelock.c @@ -347,7 +347,8 @@ rename_lock_file (char const *old, char const *new, bool force) potential race condition since some other process may create NEW immediately after the existence check, but it's the best we can portably do here. */ - if (lstat (new, &st) == 0 || errno == EOVERFLOW) + if (emacs_fstatat (AT_FDCWD, new, &st, AT_SYMLINK_NOFOLLOW) == 0 + || errno == EOVERFLOW) { errno = EEXIST; return -1; @@ -660,7 +661,7 @@ void lock_file (Lisp_Object fn) { Lisp_Object orig_fn, encoded_fn; - char *lfname; + char *lfname = NULL; lock_info_type lock_info; USE_SAFE_ALLOCA; @@ -679,28 +680,22 @@ lock_file (Lisp_Object fn) dostounix_filename (SSDATA (fn)); #endif encoded_fn = ENCODE_FILE (fn); + if (create_lockfiles) + /* Create the name of the lock-file for file fn */ + MAKE_LOCK_NAME (lfname, encoded_fn); /* See if this file is visited and has changed on disk since it was visited. */ - { - register Lisp_Object subject_buf; - - subject_buf = get_truename_buffer (orig_fn); - - if (!NILP (subject_buf) - && NILP (Fverify_visited_file_modtime (subject_buf)) - && !NILP (Ffile_exists_p (fn))) - call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); - - } + Lisp_Object subject_buf = get_truename_buffer (orig_fn); + if (!NILP (subject_buf) + && NILP (Fverify_visited_file_modtime (subject_buf)) + && !NILP (Ffile_exists_p (fn)) + && !(lfname && current_lock_owner (NULL, lfname) == -2)) + call1 (intern ("userlock--ask-user-about-supersession-threat"), fn); /* Don't do locking if the user has opted out. */ - if (create_lockfiles) + if (lfname) { - - /* Create the name of the lock-file for file fn */ - MAKE_LOCK_NAME (lfname, encoded_fn); - /* Try to lock the lock. FIXME: This ignores errors when lock_if_free returns a positive errno value. */ if (lock_if_free (&lock_info, lfname) < 0) @@ -859,7 +854,7 @@ syms_of_filelock (void) The name of the (per-buffer) lockfile is constructed by prepending a '.#' to the name of the file being locked. See also `lock-buffer' and Info node `(emacs)Interlocking'. */); - create_lockfiles = 1; + create_lockfiles = true; defsubr (&Sunlock_buffer); defsubr (&Slock_buffer); diff --git a/src/fns.c b/src/fns.c index 392196e2c7a..811d6e82001 100644 --- a/src/fns.c +++ b/src/fns.c @@ -21,6 +21,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <config.h> #include <stdlib.h> +#include <sys/random.h> #include <unistd.h> #include <filevercmp.h> #include <intprops.h> @@ -38,15 +39,12 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "puresize.h" #include "gnutls.h" -#if defined WINDOWSNT && defined HAVE_GNUTLS3 -# define gnutls_rnd w32_gnutls_rnd -#endif - static void sort_vector_copy (Lisp_Object, ptrdiff_t, Lisp_Object *restrict, Lisp_Object *restrict); enum equal_kind { EQUAL_NO_QUIT, EQUAL_PLAIN, EQUAL_INCLUDING_PROPERTIES }; static bool internal_equal (Lisp_Object, Lisp_Object, enum equal_kind, int, Lisp_Object); +static EMACS_UINT sxhash_obj (Lisp_Object, int); DEFUN ("identity", Fidentity, Sidentity, 1, 1, 0, doc: /* Return the ARGUMENT unchanged. */ @@ -225,12 +223,12 @@ Letter-case is significant, but text properties are ignored. */) for (x = 1; x <= len2; x++) { column[0] = x; - FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); + c2 = fetch_string_char_advance (string2, &i2, &i2_byte); i1 = i1_byte = 0; for (y = 1, lastdiag = x - 1; y <= len1; y++) { olddiag = column[y]; - FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); + c1 = fetch_string_char_advance (string1, &i1, &i1_byte); column[y] = min (min (column[y] + 1, column[y-1] + 1), lastdiag + (c1 == c2 ? 0 : 1)); lastdiag = olddiag; @@ -311,10 +309,8 @@ If string STR1 is greater, the value is a positive number N; { /* When we find a mismatch, we must compare the characters, not just the bytes. */ - int c1, c2; - - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c1, str1, i1, i1_byte); - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c2, str2, i2, i2_byte); + int c1 = fetch_string_char_as_multibyte_advance (str1, &i1, &i1_byte); + int c2 = fetch_string_char_as_multibyte_advance (str2, &i2, &i2_byte); if (c1 == c2) continue; @@ -349,11 +345,8 @@ DEFUN ("string-lessp", Fstring_lessp, Sstring_lessp, 2, 2, 0, doc: /* Return non-nil if STRING1 is less than STRING2 in lexicographic order. Case is significant. Symbols are also allowed; their print names are used instead. */) - (register Lisp_Object string1, Lisp_Object string2) + (Lisp_Object string1, Lisp_Object string2) { - register ptrdiff_t end; - register ptrdiff_t i1, i1_byte, i2, i2_byte; - if (SYMBOLP (string1)) string1 = SYMBOL_NAME (string1); if (SYMBOLP (string2)) @@ -361,21 +354,15 @@ Symbols are also allowed; their print names are used instead. */) CHECK_STRING (string1); CHECK_STRING (string2); - i1 = i1_byte = i2 = i2_byte = 0; - - end = SCHARS (string1); - if (end > SCHARS (string2)) - end = SCHARS (string2); + ptrdiff_t i1 = 0, i1_byte = 0, i2 = 0, i2_byte = 0; + ptrdiff_t end = min (SCHARS (string1), SCHARS (string2)); while (i1 < end) { /* When we find a mismatch, we must compare the characters, not just the bytes. */ - int c1, c2; - - FETCH_STRING_CHAR_ADVANCE (c1, string1, i1, i1_byte); - FETCH_STRING_CHAR_ADVANCE (c2, string2, i2, i2_byte); - + int c1 = fetch_string_char_advance (string1, &i1, &i1_byte); + int c2 = fetch_string_char_advance (string2, &i2, &i2_byte); if (c1 != c2) return c1 < c2 ? Qt : Qnil; } @@ -766,8 +753,8 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { Lisp_Object thislen; ptrdiff_t thisleni = 0; - register ptrdiff_t thisindex = 0; - register ptrdiff_t thisindex_byte = 0; + ptrdiff_t thisindex = 0; + ptrdiff_t thisindex_byte = 0; this = args[argnum]; if (!CONSP (this)) @@ -820,9 +807,8 @@ concat (ptrdiff_t nargs, Lisp_Object *args, { int c; if (STRING_MULTIBYTE (this)) - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, this, - thisindex, - thisindex_byte); + c = fetch_string_char_advance_no_check (this, &thisindex, + &thisindex_byte); else { c = SREF (this, thisindex); thisindex++; @@ -1544,11 +1530,21 @@ same_float (Lisp_Object x, Lisp_Object y) return !neql; } +/* True if X can be compared using `eq'. + This predicate is approximative, for maximum speed. */ +static bool +eq_comparable_value (Lisp_Object x) +{ + return SYMBOLP (x) || FIXNUMP (x); +} + DEFUN ("member", Fmember, Smember, 2, 2, 0, doc: /* Return non-nil if ELT is an element of LIST. Comparison done with `equal'. The value is actually the tail of LIST whose car is ELT. */) (Lisp_Object elt, Lisp_Object list) { + if (eq_comparable_value (elt)) + return Fmemq (elt, list); Lisp_Object tail = list; FOR_EACH_TAIL (tail) if (! NILP (Fequal (elt, XCAR (tail)))) @@ -1636,6 +1632,8 @@ The value is actually the first element of ALIST whose car equals KEY. Equality is defined by TESTFN if non-nil or by `equal' if nil. */) (Lisp_Object key, Lisp_Object alist, Lisp_Object testfn) { + if (eq_comparable_value (key) && NILP (testfn)) + return Fassq (key, alist); Lisp_Object tail = alist; FOR_EACH_TAIL (tail) { @@ -1686,6 +1684,8 @@ DEFUN ("rassoc", Frassoc, Srassoc, 2, 2, 0, The value is actually the first element of ALIST whose cdr equals KEY. */) (Lisp_Object key, Lisp_Object alist) { + if (eq_comparable_value (key)) + return Frassq (key, alist); Lisp_Object tail = alist; FOR_EACH_TAIL (tail) { @@ -1960,9 +1960,7 @@ See also the function `nreverse', which is used more often. */) p = SDATA (seq), q = SDATA (new) + bytes; while (q > SDATA (new)) { - int ch, len; - - ch = STRING_CHAR_AND_LENGTH (p, len); + int len, ch = string_char_and_length (p, &len); p += len, q -= len; CHAR_STRING (ch, q); } @@ -2433,6 +2431,9 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, same size. */ if (ASIZE (o2) != size) return false; + + /* Compare bignums, overlays, markers, and boolvectors + specially, by comparing their values. */ if (BIGNUMP (o1)) return mpz_cmp (*xbignum_val (o1), *xbignum_val (o2)) == 0; if (OVERLAYP (o1)) @@ -2453,21 +2454,12 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, && (XMARKER (o1)->buffer == 0 || XMARKER (o1)->bytepos == XMARKER (o2)->bytepos)); } - /* Boolvectors are compared much like strings. */ if (BOOL_VECTOR_P (o1)) { EMACS_INT size = bool_vector_size (o1); - if (size != bool_vector_size (o2)) - return false; - if (memcmp (bool_vector_data (o1), bool_vector_data (o2), - bool_vector_bytes (size))) - return false; - return true; - } - if (WINDOW_CONFIGURATIONP (o1)) - { - eassert (equal_kind != EQUAL_NO_QUIT); - return compare_window_configurations (o1, o2, false); + return (size == bool_vector_size (o2) + && !memcmp (bool_vector_data (o1), bool_vector_data (o2), + bool_vector_bytes (size))); } /* Aside from them, only true vectors, char-tables, compiled @@ -2493,16 +2485,11 @@ internal_equal (Lisp_Object o1, Lisp_Object o2, enum equal_kind equal_kind, break; case Lisp_String: - if (SCHARS (o1) != SCHARS (o2)) - return false; - if (SBYTES (o1) != SBYTES (o2)) - return false; - if (memcmp (SDATA (o1), SDATA (o2), SBYTES (o1))) - return false; - if (equal_kind == EQUAL_INCLUDING_PROPERTIES - && !compare_string_intervals (o1, o2)) - return false; - return true; + return (SCHARS (o1) == SCHARS (o2) + && SBYTES (o1) == SBYTES (o2) + && !memcmp (SDATA (o1), SDATA (o2), SBYTES (o1)) + && (equal_kind != EQUAL_INCLUDING_PROPERTIES + || compare_string_intervals (o1, o2))); default: break; @@ -2532,26 +2519,36 @@ ARRAY is a vector, string, char-table, or bool-vector. */) } else if (STRINGP (array)) { - register unsigned char *p = SDATA (array); - int charval; + unsigned char *p = SDATA (array); CHECK_CHARACTER (item); - charval = XFIXNAT (item); + int charval = XFIXNAT (item); size = SCHARS (array); - if (STRING_MULTIBYTE (array)) + if (size != 0) { + CHECK_IMPURE (array, XSTRING (array)); unsigned char str[MAX_MULTIBYTE_LENGTH]; - int len = CHAR_STRING (charval, str); - ptrdiff_t size_byte = SBYTES (array); - ptrdiff_t product; + int len; + if (STRING_MULTIBYTE (array)) + len = CHAR_STRING (charval, str); + else + { + str[0] = charval; + len = 1; + } - if (INT_MULTIPLY_WRAPV (size, len, &product) || product != size_byte) - error ("Attempt to change byte length of a string"); - for (idx = 0; idx < size_byte; idx++) - *p++ = str[idx % len]; + ptrdiff_t size_byte = SBYTES (array); + if (len == 1 && size == size_byte) + memset (p, str[0], size); + else + { + ptrdiff_t product; + if (INT_MULTIPLY_WRAPV (size, len, &product) + || product != size_byte) + error ("Attempt to change byte length of a string"); + for (idx = 0; idx < size_byte; idx++) + *p++ = str[idx % len]; + } } - else - for (idx = 0; idx < size; idx++) - p[idx] = charval; } else if (BOOL_VECTOR_P (array)) return bool_vector_fill (array, item); @@ -2566,12 +2563,15 @@ DEFUN ("clear-string", Fclear_string, Sclear_string, This makes STRING unibyte and may change its length. */) (Lisp_Object string) { - ptrdiff_t len; CHECK_STRING (string); - len = SBYTES (string); - memset (SDATA (string), 0, len); - STRING_SET_CHARS (string, len); - STRING_SET_UNIBYTE (string); + ptrdiff_t len = SBYTES (string); + if (len != 0 || STRING_MULTIBYTE (string)) + { + CHECK_IMPURE (string, XSTRING (string)); + memset (SDATA (string), 0, len); + STRING_SET_CHARS (string, len); + STRING_SET_UNIBYTE (string); + } return Qnil; } @@ -2624,51 +2624,45 @@ usage: (nconc &rest LISTS) */) static EMACS_INT mapcar1 (EMACS_INT leni, Lisp_Object *vals, Lisp_Object fn, Lisp_Object seq) { - Lisp_Object tail, dummy; - EMACS_INT i; - if (VECTORP (seq) || COMPILEDP (seq)) { - for (i = 0; i < leni; i++) + for (ptrdiff_t i = 0; i < leni; i++) { - dummy = call1 (fn, AREF (seq, i)); + Lisp_Object dummy = call1 (fn, AREF (seq, i)); if (vals) vals[i] = dummy; } } else if (BOOL_VECTOR_P (seq)) { - for (i = 0; i < leni; i++) + for (EMACS_INT i = 0; i < leni; i++) { - dummy = call1 (fn, bool_vector_ref (seq, i)); + Lisp_Object dummy = call1 (fn, bool_vector_ref (seq, i)); if (vals) vals[i] = dummy; } } else if (STRINGP (seq)) { - ptrdiff_t i_byte; + ptrdiff_t i_byte = 0; - for (i = 0, i_byte = 0; i < leni;) + for (ptrdiff_t i = 0; i < leni;) { - int c; ptrdiff_t i_before = i; - - FETCH_STRING_CHAR_ADVANCE (c, seq, i, i_byte); - XSETFASTINT (dummy, c); - dummy = call1 (fn, dummy); + int c = fetch_string_char_advance (seq, &i, &i_byte); + Lisp_Object dummy = call1 (fn, make_fixnum (c)); if (vals) vals[i_before] = dummy; } } else /* Must be a list, since Flength did not get an error */ { - tail = seq; - for (i = 0; i < leni; i++) + Lisp_Object tail = seq; + for (ptrdiff_t i = 0; i < leni; i++) { if (! CONSP (tail)) return i; - dummy = call1 (fn, XCAR (tail)); + Lisp_Object dummy = call1 (fn, XCAR (tail)); if (vals) vals[i] = dummy; tail = XCDR (tail); @@ -2853,7 +2847,7 @@ advisable. */) while (loads-- > 0) { Lisp_Object load = (NILP (use_floats) - ? make_fixnum (100.0 * load_ave[loads]) + ? double_to_integer (100.0 * load_ave[loads]) : make_float (load_ave[loads])); ret = Fcons (load, ret); } @@ -3461,7 +3455,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, { if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3504,7 +3498,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3529,7 +3523,7 @@ base64_encode_1 (const char *from, char *to, ptrdiff_t length, if (multibyte) { - c = STRING_CHAR_AND_LENGTH ((unsigned char *) from + i, bytes); + c = string_char_and_length ((unsigned char *) from + i, &bytes); if (CHAR_BYTE8_P (c)) c = CHAR_TO_BYTE8 (c); else if (c >= 256) @@ -3710,7 +3704,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value >> 16 & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -3752,7 +3746,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value >> 8 & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -3782,7 +3776,7 @@ base64_decode_1 (const char *from, char *to, ptrdiff_t length, c = value & 0xff; if (c & multibyte_bit) - e += BYTE8_STRING (c, e); + e += BYTE8_STRING (c, (unsigned char *) e); else *e++ = c; nchars++; @@ -4022,7 +4016,7 @@ hashfn_eq (Lisp_Object key, struct Lisp_Hash_Table *h) Lisp_Object hashfn_equal (Lisp_Object key, struct Lisp_Hash_Table *h) { - return make_ufixnum (sxhash (key, 0)); + return make_ufixnum (sxhash (key)); } /* Ignore HT and return a hash code for KEY which uses 'eql' to compare keys. @@ -4042,7 +4036,7 @@ hashfn_user_defined (Lisp_Object key, struct Lisp_Hash_Table *h) { Lisp_Object args[] = { h->test.user_hash_function, key }; Lisp_Object hash = hash_table_user_defined_call (ARRAYELTS (args), args, h); - return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash, 0)); + return FIXNUMP (hash) ? hash : make_ufixnum (sxhash (hash)); } struct hash_table_test const @@ -4422,7 +4416,7 @@ hash_clear (struct Lisp_Hash_Table *h) { ptrdiff_t size = HASH_TABLE_SIZE (h); if (!hash_rehash_needed_p (h)) - memclear (XVECTOR (h->hash)->contents, size * word_size); + memclear (xvector_contents (h->hash), size * word_size); for (ptrdiff_t i = 0; i < size; i++) { set_hash_next_slot (h, i, i < size - 1 ? i + 1 : -1); @@ -4606,13 +4600,13 @@ sxhash_list (Lisp_Object list, int depth) CONSP (list) && i < SXHASH_MAX_LEN; list = XCDR (list), ++i) { - EMACS_UINT hash2 = sxhash (XCAR (list), depth + 1); + EMACS_UINT hash2 = sxhash_obj (XCAR (list), depth + 1); hash = sxhash_combine (hash, hash2); } if (!NILP (list)) { - EMACS_UINT hash2 = sxhash (list, depth + 1); + EMACS_UINT hash2 = sxhash_obj (list, depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4632,7 +4626,7 @@ sxhash_vector (Lisp_Object vec, int depth) n = min (SXHASH_MAX_LEN, hash & PSEUDOVECTOR_FLAG ? PVSIZE (vec) : hash); for (i = 0; i < n; ++i) { - EMACS_UINT hash2 = sxhash (AREF (vec, i), depth + 1); + EMACS_UINT hash2 = sxhash_obj (AREF (vec, i), depth + 1); hash = sxhash_combine (hash, hash2); } @@ -4675,58 +4669,78 @@ sxhash_bignum (Lisp_Object bignum) structure. Value is an unsigned integer clipped to INTMASK. */ EMACS_UINT -sxhash (Lisp_Object obj, int depth) +sxhash (Lisp_Object obj) { - EMACS_UINT hash; + return sxhash_obj (obj, 0); +} +static EMACS_UINT +sxhash_obj (Lisp_Object obj, int depth) +{ if (depth > SXHASH_MAX_DEPTH) return 0; switch (XTYPE (obj)) { case_Lisp_Int: - hash = XUFIXNUM (obj); - break; + return XUFIXNUM (obj); case Lisp_Symbol: - hash = XHASH (obj); - break; + return XHASH (obj); case Lisp_String: - hash = sxhash_string (SSDATA (obj), SBYTES (obj)); - break; + return sxhash_string (SSDATA (obj), SBYTES (obj)); - /* This can be everything from a vector to an overlay. */ case Lisp_Vectorlike: - if (BIGNUMP (obj)) - hash = sxhash_bignum (obj); - else if (VECTORP (obj) || RECORDP (obj)) - /* According to the CL HyperSpec, two arrays are equal only if - they are `eq', except for strings and bit-vectors. In - Emacs, this works differently. We have to compare element - by element. Same for records. */ - hash = sxhash_vector (obj, depth); - else if (BOOL_VECTOR_P (obj)) - hash = sxhash_bool_vector (obj); - else - /* Others are `equal' if they are `eq', so let's take their - address as hash. */ - hash = XHASH (obj); - break; + { + enum pvec_type pvec_type = PSEUDOVECTOR_TYPE (XVECTOR (obj)); + if (! (PVEC_NORMAL_VECTOR < pvec_type && pvec_type < PVEC_COMPILED)) + { + /* According to the CL HyperSpec, two arrays are equal only if + they are 'eq', except for strings and bit-vectors. In + Emacs, this works differently. We have to compare element + by element. Same for pseudovectors that internal_equal + examines the Lisp contents of. */ + return (SUB_CHAR_TABLE_P (obj) + /* 'sxhash_vector' can't be applies to a sub-char-table and + it's probably not worth looking into them anyway! */ + ? 42 + : sxhash_vector (obj, depth)); + } + else if (pvec_type == PVEC_BIGNUM) + return sxhash_bignum (obj); + else if (pvec_type == PVEC_MARKER) + { + ptrdiff_t bytepos + = XMARKER (obj)->buffer ? XMARKER (obj)->bytepos : 0; + EMACS_UINT hash + = sxhash_combine ((intptr_t) XMARKER (obj)->buffer, bytepos); + return SXHASH_REDUCE (hash); + } + else if (pvec_type == PVEC_BOOL_VECTOR) + return sxhash_bool_vector (obj); + else if (pvec_type == PVEC_OVERLAY) + { + EMACS_UINT hash = sxhash_obj (OVERLAY_START (obj), depth); + hash = sxhash_combine (hash, sxhash_obj (OVERLAY_END (obj), depth)); + hash = sxhash_combine (hash, sxhash_obj (XOVERLAY (obj)->plist, depth)); + return SXHASH_REDUCE (hash); + } + else + /* Others are 'equal' if they are 'eq', so take their + address as hash. */ + return XHASH (obj); + } case Lisp_Cons: - hash = sxhash_list (obj, depth); - break; + return sxhash_list (obj, depth); case Lisp_Float: - hash = sxhash_float (XFLOAT_DATA (obj)); - break; + return sxhash_float (XFLOAT_DATA (obj)); default: emacs_abort (); } - - return hash; } @@ -5177,22 +5191,8 @@ extract_data_from_object (Lisp_Object spec, struct buffer *bp = XBUFFER (object); set_buffer_internal (bp); - if (NILP (start)) - b = BEGV; - else - { - CHECK_FIXNUM_COERCE_MARKER (start); - b = XFIXNUM (start); - } - - if (NILP (end)) - e = ZV; - else - { - CHECK_FIXNUM_COERCE_MARKER (end); - e = XFIXNUM (end); - } - + b = !NILP (start) ? fix_position (start) : BEGV; + e = !NILP (end) ? fix_position (end) : ZV; if (b > e) { EMACS_INT temp = b; @@ -5278,7 +5278,6 @@ extract_data_from_object (Lisp_Object spec, } else if (EQ (object, Qiv_auto)) { -#ifdef HAVE_GNUTLS3 /* Format: (iv-auto REQUIRED-LENGTH). */ if (! FIXNATP (start)) @@ -5287,14 +5286,19 @@ extract_data_from_object (Lisp_Object spec, { EMACS_INT start_hold = XFIXNAT (start); object = make_uninit_string (start_hold); - gnutls_rnd (GNUTLS_RND_NONCE, SSDATA (object), start_hold); + char *lim = SSDATA (object) + start_hold; + for (char *p = SSDATA (object); p < lim; p++) + { + ssize_t gotten = getrandom (p, lim - p, 0); + if (0 <= gotten) + p += gotten; + else if (errno != EINTR) + report_file_error ("Getting random data", Qnil); + } *start_byte = 0; *end_byte = start_hold; } -#else - error ("GnuTLS is not available, so `iv-auto' can't be used"); -#endif } if (!STRINGP (object)) diff --git a/src/font.c b/src/font.c index 39ec1b3562a..ab00402b40b 100644 --- a/src/font.c +++ b/src/font.c @@ -3856,13 +3856,10 @@ font_range (ptrdiff_t pos, ptrdiff_t pos_byte, ptrdiff_t *limit, while (pos < *limit) { - Lisp_Object category; - - if (NILP (string)) - FETCH_CHAR_ADVANCE_NO_CHECK (c, pos, pos_byte); - else - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, string, pos, pos_byte); - category = CHAR_TABLE_REF (Vunicode_category_table, c); + c = (NILP (string) + ? fetch_char_advance_no_check (&pos, &pos_byte) + : fetch_string_char_advance_no_check (string, &pos, &pos_byte)); + Lisp_Object category = CHAR_TABLE_REF (Vunicode_category_table, c); if (FIXNUMP (category) && (XFIXNUM (category) == UNICODE_CATEGORY_Cf || CHAR_VARIATION_SELECTOR_P (c))) @@ -4606,10 +4603,10 @@ DEFUN ("internal-char-font", Finternal_char_font, Sinternal_char_font, 1, 2, 0, Lisp_Object window; struct window *w; - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + EMACS_INT fixed_pos = fix_position (position); + if (! (BEGV <= fixed_pos && fixed_pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); - pos = XFIXNUM (position); + pos = fixed_pos; pos_byte = CHAR_TO_BYTE (pos); if (NILP (ch)) c = FETCH_CHAR (pos_byte); @@ -4891,7 +4888,7 @@ the corresponding element is nil. */) Lisp_Object object) { struct font *font = CHECK_FONT_GET_OBJECT (font_object); - ptrdiff_t i, len; + ptrdiff_t len; Lisp_Object *chars, vec; USE_SAFE_ALLOCA; @@ -4906,10 +4903,9 @@ the corresponding element is nil. */) SAFE_ALLOCA_LISP (chars, len); charpos = XFIXNAT (from); bytepos = CHAR_TO_BYTE (charpos); - for (i = 0; charpos < XFIXNAT (to); i++) + for (ptrdiff_t i = 0; charpos < XFIXNAT (to); i++) { - int c; - FETCH_CHAR_ADVANCE (c, charpos, bytepos); + int c = fetch_char_advance (&charpos, &bytepos); chars[i] = make_fixnum (c); } } @@ -4929,18 +4925,18 @@ the corresponding element is nil. */) int c; /* Skip IFROM characters from the beginning. */ - for (i = 0; i < ifrom; i++) - c = STRING_CHAR_ADVANCE (p); + for (ptrdiff_t i = 0; i < ifrom; i++) + p += BYTES_BY_CHAR_HEAD (*p); /* Now fetch an interesting characters. */ - for (i = 0; i < len; i++) - { - c = STRING_CHAR_ADVANCE (p); - chars[i] = make_fixnum (c); - } + for (ptrdiff_t i = 0; i < len; i++) + { + c = string_char_advance (&p); + chars[i] = make_fixnum (c); + } } else - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) chars[i] = make_fixnum (p[ifrom + i]); } else if (VECTORP (object)) @@ -4951,7 +4947,7 @@ the corresponding element is nil. */) if (ifrom == ito) return Qnil; len = ito - ifrom; - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) { Lisp_Object elt = AREF (object, ifrom + i); CHECK_CHARACTER (elt); @@ -4962,7 +4958,7 @@ the corresponding element is nil. */) wrong_type_argument (Qarrayp, object); vec = make_uninit_vector (len); - for (i = 0; i < len; i++) + for (ptrdiff_t i = 0; i < len; i++) { Lisp_Object g; int c = XFIXNAT (chars[i]); @@ -5013,24 +5009,26 @@ character at index specified by POSITION. */) (Lisp_Object position, Lisp_Object window, Lisp_Object string) { struct window *w = decode_live_window (window); + EMACS_INT pos; if (NILP (string)) { if (XBUFFER (w->contents) != current_buffer) error ("Specified window is not displaying the current buffer"); - CHECK_FIXNUM_COERCE_MARKER (position); - if (! (BEGV <= XFIXNUM (position) && XFIXNUM (position) < ZV)) + pos = fix_position (position); + if (! (BEGV <= pos && pos < ZV)) args_out_of_range_3 (position, make_fixnum (BEGV), make_fixnum (ZV)); } else { CHECK_FIXNUM (position); CHECK_STRING (string); - if (! (0 <= XFIXNUM (position) && XFIXNUM (position) < SCHARS (string))) + pos = XFIXNUM (position); + if (! (0 <= pos && pos < SCHARS (string))) args_out_of_range (string, position); } - return font_at (-1, XFIXNUM (position), NULL, w, string); + return font_at (-1, pos, NULL, w, string); } #if 0 @@ -5543,7 +5541,6 @@ cause Xft crashes. Only has an effect in Xft builds. */); #ifdef USE_CAIRO syms_of_ftcrfont (); #else - syms_of_ftxfont (); #ifdef HAVE_XFT syms_of_xftfont (); #endif /* HAVE_XFT */ diff --git a/src/font.h b/src/font.h index 6f4792afe55..8614e7fa10a 100644 --- a/src/font.h +++ b/src/font.h @@ -69,8 +69,8 @@ INLINE_HEADER_BEGIN enum font_property_index { - /* FONT-TYPE is a symbol indicating a font backend; currently `x', - `xft', and `ftx' are available on X, `uniscribe' and `gdi' on + /* FONT-TYPE is a symbol indicating a font backend; currently `x' + and `xft' are available on X, `uniscribe' and `gdi' on Windows, and `ns' under Cocoa / GNUstep. */ FONT_TYPE_INDEX, @@ -938,7 +938,6 @@ extern void syms_of_ftfont (void); extern struct font_driver const xfont_driver; extern Lisp_Object xfont_get_cache (struct frame *); extern void syms_of_xfont (void); -extern void syms_of_ftxfont (void); #ifdef HAVE_XFT extern struct font_driver const xftfont_driver; #ifdef HAVE_HARFBUZZ @@ -946,7 +945,6 @@ extern struct font_driver xfthbfont_driver; #endif /* HAVE_HARFBUZZ */ #endif #if defined HAVE_FREETYPE || defined HAVE_XFT -extern struct font_driver const ftxfont_driver; extern void syms_of_xftfont (void); #endif #ifdef HAVE_BDFFONT diff --git a/src/frame.c b/src/frame.c index 4dd8bb18041..c871e4fd994 100644 --- a/src/frame.c +++ b/src/frame.c @@ -904,7 +904,7 @@ make_frame (bool mini_p) f->last_tool_bar_item = -1; #endif #ifdef NS_IMPL_COCOA - f->ns_appearance = ns_appearance_aqua; + f->ns_appearance = ns_appearance_system_default; f->ns_transparent_titlebar = false; #endif #endif @@ -2558,26 +2558,26 @@ before calling this function on it, like this. (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { CHECK_LIVE_FRAME (frame); - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); + frame_set_mouse_position (XFRAME (frame), xval, yval); #else #if defined (MSDOS) if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } #else #ifdef HAVE_GPM { Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + term_mouse_moveto (xval, yval); } #endif #endif @@ -2599,26 +2599,26 @@ before calling this function on it, like this. (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { CHECK_LIVE_FRAME (frame); - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); /* I think this should be done with a hook. */ #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (XFRAME (frame))) /* Warping the mouse will cause enternotify and focus events. */ - frame_set_mouse_pixel_position (XFRAME (frame), XFIXNUM (x), XFIXNUM (y)); + frame_set_mouse_pixel_position (XFRAME (frame), xval, yval); #else #if defined (MSDOS) if (FRAME_MSDOS_P (XFRAME (frame))) { Fselect_frame (frame, Qnil); - mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + mouse_moveto (xval, yval); } #else #ifdef HAVE_GPM { Fselect_frame (frame, Qnil); - term_mouse_moveto (XFIXNUM (x), XFIXNUM (y)); + term_mouse_moveto (xval, yval); } #endif #endif @@ -3545,6 +3545,21 @@ DEFUN ("frame-bottom-divider-width", Fbottom_divider_width, Sbottom_divider_widt return make_fixnum (FRAME_BOTTOM_DIVIDER_WIDTH (decode_any_frame (frame))); } +static int +check_frame_pixels (Lisp_Object size, Lisp_Object pixelwise, int item_size) +{ + CHECK_INTEGER (size); + if (!NILP (pixelwise)) + item_size = 1; + intmax_t sz; + int pixel_size; /* size * item_size */ + if (! integer_to_intmax (size, &sz) + || INT_MULTIPLY_WRAPV (sz, item_size, &pixel_size)) + args_out_of_range_3 (size, make_int (INT_MIN / item_size), + make_int (INT_MAX / item_size)); + return pixel_size; +} + DEFUN ("set-frame-height", Fset_frame_height, Sset_frame_height, 2, 4, "(list (selected-frame) (prefix-numeric-value current-prefix-arg))", doc: /* Set text height of frame FRAME to HEIGHT lines. @@ -3562,15 +3577,9 @@ currently selected frame will be set to this height. */) (Lisp_Object frame, Lisp_Object height, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_height; - - CHECK_TYPE_RANGED_INTEGER (int, height); - - pixel_height = (!NILP (pixelwise) - ? XFIXNUM (height) - : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); + int pixel_height = check_frame_pixels (height, pixelwise, + FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, -1, pixel_height, 1, !NILP (pretend), Qheight); - return Qnil; } @@ -3591,15 +3600,9 @@ currently selected frame will be set to this width. */) (Lisp_Object frame, Lisp_Object width, Lisp_Object pretend, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_width; - - CHECK_TYPE_RANGED_INTEGER (int, width); - - pixel_width = (!NILP (pixelwise) - ? XFIXNUM (width) - : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); + int pixel_width = check_frame_pixels (width, pixelwise, + FRAME_COLUMN_WIDTH (f)); adjust_frame_size (f, pixel_width, -1, 1, !NILP (pretend), Qwidth); - return Qnil; } @@ -3613,19 +3616,11 @@ font height. */) (Lisp_Object frame, Lisp_Object width, Lisp_Object height, Lisp_Object pixelwise) { struct frame *f = decode_live_frame (frame); - int pixel_width, pixel_height; - - CHECK_TYPE_RANGED_INTEGER (int, width); - CHECK_TYPE_RANGED_INTEGER (int, height); - - pixel_width = (!NILP (pixelwise) - ? XFIXNUM (width) - : XFIXNUM (width) * FRAME_COLUMN_WIDTH (f)); - pixel_height = (!NILP (pixelwise) - ? XFIXNUM (height) - : XFIXNUM (height) * FRAME_LINE_HEIGHT (f)); + int pixel_width = check_frame_pixels (width, pixelwise, + FRAME_COLUMN_WIDTH (f)); + int pixel_height = check_frame_pixels (height, pixelwise, + FRAME_LINE_HEIGHT (f)); adjust_frame_size (f, pixel_width, pixel_height, 1, 0, Qsize); - return Qnil; } @@ -3655,18 +3650,14 @@ bottom edge of FRAME's display. */) (Lisp_Object frame, Lisp_Object x, Lisp_Object y) { struct frame *f = decode_live_frame (frame); - - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); if (FRAME_WINDOW_P (f)) { #ifdef HAVE_WINDOW_SYSTEM if (FRAME_TERMINAL (f)->set_frame_offset_hook) - FRAME_TERMINAL (f)->set_frame_offset_hook (f, - XFIXNUM (x), - XFIXNUM (y), - 1); + FRAME_TERMINAL (f)->set_frame_offset_hook (f, xval, yval, 1); #endif } @@ -4641,23 +4632,22 @@ gui_set_right_fringe (struct frame *f, Lisp_Object new_value, Lisp_Object old_va void gui_set_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - CHECK_TYPE_RANGED_INTEGER (int, arg); + int border_width = check_integer_range (arg, INT_MIN, INT_MAX); - if (XFIXNUM (arg) == f->border_width) + if (border_width == f->border_width) return; if (FRAME_NATIVE_WINDOW (f) != 0) error ("Cannot change the border width of a frame"); - f->border_width = XFIXNUM (arg); + f->border_width = border_width; } void gui_set_right_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_RIGHT_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - int new = max (0, XFIXNUM (arg)); + int new = check_int_nonnegative (arg); if (new != old) { f->right_divider_width = new; @@ -4671,8 +4661,7 @@ void gui_set_bottom_divider_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old = FRAME_BOTTOM_DIVIDER_WIDTH (f); - CHECK_TYPE_RANGED_INTEGER (int, arg); - int new = max (0, XFIXNUM (arg)); + int new = check_int_nonnegative (arg); if (new != old) { f->bottom_divider_width = new; @@ -5651,8 +5640,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object parms, bool tabbar_p, f->top_pos = 0; else { - CHECK_TYPE_RANGED_INTEGER (int, top); - f->top_pos = XFIXNUM (top); + f->top_pos = check_integer_range (top, INT_MIN, INT_MAX); if (f->top_pos < 0) window_prompting |= YNegative; } @@ -5682,8 +5670,7 @@ gui_figure_window_size (struct frame *f, Lisp_Object parms, bool tabbar_p, f->left_pos = 0; else { - CHECK_TYPE_RANGED_INTEGER (int, left); - f->left_pos = XFIXNUM (left); + f->left_pos = check_integer_range (left, INT_MIN, INT_MAX); if (f->left_pos < 0) window_prompting |= XNegative; } diff --git a/src/frame.h b/src/frame.h index a54b8623e50..476bac67faf 100644 --- a/src/frame.h +++ b/src/frame.h @@ -69,8 +69,9 @@ enum internal_border_part #ifdef NS_IMPL_COCOA enum ns_appearance_type { - ns_appearance_aqua, - ns_appearance_vibrant_dark + ns_appearance_system_default, + ns_appearance_aqua, + ns_appearance_vibrant_dark }; #endif #endif /* HAVE_WINDOW_SYSTEM */ @@ -1449,6 +1450,49 @@ FRAME_BOTTOM_DIVIDER_WIDTH (struct frame *f) { return frame_dimension (f->bottom_divider_width); } + +/* Return a non-null pointer to the cached face with ID on frame F. */ + +INLINE struct face * +FACE_FROM_ID (struct frame *f, int id) +{ + eassert (0 <= id && id < FRAME_FACE_CACHE (f)->used); + return FRAME_FACE_CACHE (f)->faces_by_id[id]; +} + +/* Return a pointer to the face with ID on frame F, or null if such a + face doesn't exist. */ + +INLINE struct face * +FACE_FROM_ID_OR_NULL (struct frame *f, int id) +{ + int used = FRAME_FACE_CACHE (f)->used; + eassume (0 <= used); + return 0 <= id && id < used ? FRAME_FACE_CACHE (f)->faces_by_id[id] : NULL; +} + +#ifdef HAVE_WINDOW_SYSTEM + +/* A non-null pointer to the image with id ID on frame F. */ + +INLINE struct image * +IMAGE_FROM_ID (struct frame *f, int id) +{ + eassert (0 <= id && id < FRAME_IMAGE_CACHE (f)->used); + return FRAME_IMAGE_CACHE (f)->images[id]; +} + +/* Value is a pointer to the image with id ID on frame F, or null if + no image with that id exists. */ + +INLINE struct image * +IMAGE_OPT_FROM_ID (struct frame *f, int id) +{ + int used = FRAME_IMAGE_CACHE (f)->used; + eassume (0 <= used); + return 0 <= id && id < used ? FRAME_IMAGE_CACHE (f)->images[id] : NULL; +} +#endif /*********************************************************************** Conversion between canonical units and pixels diff --git a/src/fringe.c b/src/fringe.c index 2a46e3c34f2..fc4c738dc2d 100644 --- a/src/fringe.c +++ b/src/fringe.c @@ -101,7 +101,7 @@ struct fringe_bitmap ...xx... */ static unsigned short question_mark_bits[] = { - 0x3c, 0x7e, 0x7e, 0x0c, 0x18, 0x18, 0x00, 0x18, 0x18}; + 0x3c, 0x7e, 0xc3, 0xc3, 0x0c, 0x18, 0x18, 0x00, 0x18, 0x18}; /* An exclamation mark. */ /* @@ -117,7 +117,7 @@ static unsigned short question_mark_bits[] = { ...XX... */ static unsigned short exclamation_mark_bits[] = { - 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x00, 0x18}; + 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x18, 0x00, 0x18, 0x18}; /* An arrow like this: `<-'. */ /* @@ -1675,10 +1675,10 @@ Return nil if POS is not visible in WINDOW. */) if (!NILP (pos)) { - CHECK_FIXNUM_COERCE_MARKER (pos); - if (! (BEGV <= XFIXNUM (pos) && XFIXNUM (pos) <= ZV)) + EMACS_INT p = fix_position (pos); + if (! (BEGV <= p && p <= ZV)) args_out_of_range (window, pos); - textpos = XFIXNUM (pos); + textpos = p; } else if (w == XWINDOW (selected_window)) textpos = PT; diff --git a/src/ftcrfont.c b/src/ftcrfont.c index a0e18e13cfa..7832d4f5ce0 100644 --- a/src/ftcrfont.c +++ b/src/ftcrfont.c @@ -328,14 +328,13 @@ ftcrfont_encode_char (struct font *font, int c) struct font_info *ftcrfont_info = (struct font_info *) font; unsigned code = FONT_INVALID_CODE; unsigned char utf8[MAX_MULTIBYTE_LENGTH]; - unsigned char *p = utf8; + int utf8len = CHAR_STRING (c, utf8); cairo_glyph_t stack_glyph; cairo_glyph_t *glyphs = &stack_glyph; int num_glyphs = 1; - CHAR_STRING_ADVANCE (c, p); if (cairo_scaled_font_text_to_glyphs (ftcrfont_info->cr_scaled_font, 0, 0, - (char *) utf8, p - utf8, + (char *) utf8, utf8len, &glyphs, &num_glyphs, NULL, NULL, NULL) == CAIRO_STATUS_SUCCESS) diff --git a/src/ftfont.c b/src/ftfont.c index 6b549c3ddf2..696f5e65341 100644 --- a/src/ftfont.c +++ b/src/ftfont.c @@ -346,18 +346,15 @@ struct ftfont_cache_data static Lisp_Object ftfont_lookup_cache (Lisp_Object key, enum ftfont_cache_for cache_for) { - Lisp_Object cache, val, entity; + Lisp_Object cache, val; struct ftfont_cache_data *cache_data; if (FONT_ENTITY_P (key)) { - entity = key; - val = assq_no_quit (QCfont_entity, AREF (entity, FONT_EXTRA_INDEX)); + val = assq_no_quit (QCfont_entity, AREF (key, FONT_EXTRA_INDEX)); eassert (CONSP (val)); key = XCDR (val); } - else - entity = Qnil; if (NILP (ft_face_cache)) cache = Qnil; diff --git a/src/ftxfont.c b/src/ftxfont.c deleted file mode 100644 index 9bbb2c064c2..00000000000 --- a/src/ftxfont.c +++ /dev/null @@ -1,371 +0,0 @@ -/* ftxfont.c -- FreeType font driver on X (without using XFT). - Copyright (C) 2006-2020 Free Software Foundation, Inc. - Copyright (C) 2006, 2007, 2008, 2009, 2010, 2011 - National Institute of Advanced Industrial Science and Technology (AIST) - Registration Number H13PRO009 - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ - -#include <config.h> -#include <X11/Xlib.h> - -#include "lisp.h" -#include "xterm.h" -#include "frame.h" -#include "blockinput.h" -#include "font.h" -#include "pdumper.h" - -/* FTX font driver. */ - -struct ftxfont_frame_data -{ - /* Background and foreground colors. */ - XColor colors[2]; - /* GCs interpolating the above colors. gcs[0] is for a color - closest to BACKGROUND, and gcs[5] is for a color closest to - FOREGROUND. */ - GC gcs[6]; - struct ftxfont_frame_data *next; -}; - - -/* Return an array of 6 GCs for antialiasing. */ - -static GC * -ftxfont_get_gcs (struct frame *f, unsigned long foreground, unsigned long background) -{ - XColor color; - XGCValues xgcv; - int i; - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - struct ftxfont_frame_data *prev = NULL, *this = NULL, *new; - - if (data) - { - for (this = data; this; prev = this, this = this->next) - { - if (this->colors[0].pixel < background) - continue; - if (this->colors[0].pixel > background) - break; - if (this->colors[1].pixel < foreground) - continue; - if (this->colors[1].pixel > foreground) - break; - return this->gcs; - } - } - - new = xmalloc (sizeof *new); - new->next = this; - if (prev) - prev->next = new; - font_put_frame_data (f, Qftx, new); - - new->colors[0].pixel = background; - new->colors[1].pixel = foreground; - - block_input (); - XQueryColors (FRAME_X_DISPLAY (f), FRAME_X_COLORMAP (f), new->colors, 2); - for (i = 1; i < 7; i++) - { - /* Interpolate colors linearly. Any better algorithm? */ - color.red - = (new->colors[1].red * i + new->colors[0].red * (8 - i)) / 8; - color.green - = (new->colors[1].green * i + new->colors[0].green * (8 - i)) / 8; - color.blue - = (new->colors[1].blue * i + new->colors[0].blue * (8 - i)) / 8; - if (! x_alloc_nearest_color (f, FRAME_X_COLORMAP (f), &color)) - break; - xgcv.foreground = color.pixel; - new->gcs[i - 1] = XCreateGC (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - GCForeground, &xgcv); - } - unblock_input (); - - if (i < 7) - { - block_input (); - for (i--; i >= 0; i--) - XFreeGC (FRAME_X_DISPLAY (f), new->gcs[i]); - unblock_input (); - if (prev) - prev->next = new->next; - else if (data) - font_put_frame_data (f, Qftx, new->next); - xfree (new); - return NULL; - } - return new->gcs; -} - -static int -ftxfont_draw_bitmap (struct frame *f, GC gc_fore, GC *gcs, struct font *font, - unsigned int code, int x, int y, XPoint *p, int size, - int *n, bool flush) -{ - struct font_bitmap bitmap; - unsigned char *b; - int i, j; - - if (ftfont_get_bitmap (font, code, &bitmap, size > 0x100 ? 1 : 8) < 0) - return 0; - if (size > 0x100) - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - if (b[j / 8] & (1 << (7 - (j % 8)))) - { - p[n[0]].x = x + bitmap.left + j; - p[n[0]].y = y - bitmap.top + i; - if (++n[0] == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, size, CoordModeOrigin); - n[0] = 0; - } - } - } - if (flush && n[0] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p, n[0], CoordModeOrigin); - } - else - { - for (i = 0, b = bitmap.buffer; i < bitmap.rows; - i++, b += bitmap.pitch) - { - for (j = 0; j < bitmap.width; j++) - { - int idx = (bitmap.bits_per_pixel == 1 - ? ((b[j / 8] & (1 << (7 - (j % 8)))) ? 6 : -1) - : (b[j] >> 5) - 1); - - if (idx >= 0) - { - XPoint *pp = p + size * idx; - - pp[n[idx]].x = x + bitmap.left + j; - pp[n[idx]].y = y - bitmap.top + i; - if (++(n[idx]) == size) - { - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - idx == 6 ? gc_fore : gcs[idx], pp, size, - CoordModeOrigin); - n[idx] = 0; - } - } - } - } - if (flush) - { - for (i = 0; i < 6; i++) - if (n[i] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gcs[i], p + 0x100 * i, n[i], CoordModeOrigin); - if (n[6] > 0) - XDrawPoints (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), - gc_fore, p + 0x600, n[6], CoordModeOrigin); - } - } - - /* There is no ftfont_free_bitmap, so do not try to free BITMAP. */ - - return bitmap.advance; -} - -static void -ftxfont_draw_background (struct frame *f, struct font *font, GC gc, int x, int y, - int width) -{ - XGCValues xgcv; - - XGetGCValues (FRAME_X_DISPLAY (f), gc, - GCForeground | GCBackground, &xgcv); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.background); - XFillRectangle (FRAME_X_DISPLAY (f), FRAME_X_DRAWABLE (f), gc, - x, y - FONT_BASE (font), width, FONT_HEIGHT (font)); - XSetForeground (FRAME_X_DISPLAY (f), gc, xgcv.foreground); -} - -static Lisp_Object -ftxfont_list (struct frame *f, Lisp_Object spec) -{ - return ftfont_list2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_match (struct frame *f, Lisp_Object spec) -{ - return ftfont_match2 (f, spec, Qftx); -} - -static Lisp_Object -ftxfont_open (struct frame *f, Lisp_Object entity, int pixel_size) -{ - Lisp_Object font_object = ftfont_open (f, entity, pixel_size); - if (NILP (font_object)) - return Qnil; - struct font *font = XFONT_OBJECT (font_object); - font->driver = &ftxfont_driver; - return font_object; -} - -static void -ftxfont_close (struct font *font) -{ - ftfont_close (font); -} - -static int -ftxfont_draw (struct glyph_string *s, int from, int to, int x, int y, - bool with_background) -{ - struct frame *f = s->f; - struct face *face = s->face; - struct font *font = s->font; - XPoint p[0x700]; - int n[7]; - unsigned *code = s->char2b + from; - int len = to - from; - int i; - GC *gcs; - int xadvance; - - n[0] = n[1] = n[2] = n[3] = n[4] = n[5] = n[6] = 0; - - block_input (); - if (with_background) - ftxfont_draw_background (f, font, s->gc, x, y, s->width); - - if (face->gc == s->gc) - { - gcs = ftxfont_get_gcs (f, face->foreground, face->background); - } - else - { - XGCValues xgcv; - unsigned long mask = GCForeground | GCBackground; - - XGetGCValues (FRAME_X_DISPLAY (f), s->gc, mask, &xgcv); - gcs = ftxfont_get_gcs (f, xgcv.foreground, xgcv.background); - } - - if (gcs) - { - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipRectangles (FRAME_X_DISPLAY (f), gcs[i], 0, 0, - s->clip, s->num_clips, Unsorted); - - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, gcs, font, code[i], x, y, - p, 0x100, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - if (s->num_clips) - for (i = 0; i < 6; i++) - XSetClipMask (FRAME_X_DISPLAY (f), gcs[i], None); - } - else - { - /* We can't draw with antialiasing. - s->gc should already have a proper clipping setting. */ - for (i = 0; i < len; i++) - { - xadvance = ftxfont_draw_bitmap (f, s->gc, NULL, font, code[i], x, y, - p, 0x700, n, i + 1 == len); - x += (s->padding_p ? 1 : xadvance); - } - } - - unblock_input (); - - return len; -} - -static int -ftxfont_end_for_frame (struct frame *f) -{ - struct ftxfont_frame_data *data = font_get_frame_data (f, Qftx); - - block_input (); - while (data) - { - struct ftxfont_frame_data *next = data->next; - int i; - - for (i = 0; i < 6; i++) - XFreeGC (FRAME_X_DISPLAY (f), data->gcs[i]); - xfree (data); - data = next; - } - unblock_input (); - font_put_frame_data (f, Qftx, NULL); - return 0; -} - - - -static void syms_of_ftxfont_for_pdumper (void); - -struct font_driver const ftxfont_driver = - { - /* We can't draw a text without device dependent functions. */ - .type = LISPSYM_INITIALLY (Qftx), - .get_cache = ftfont_get_cache, - .list = ftxfont_list, - .match = ftxfont_match, - .list_family = ftfont_list_family, - .open_font = ftxfont_open, - .close_font = ftxfont_close, - .has_char = ftfont_has_char, - .encode_char = ftfont_encode_char, - .text_extents = ftfont_text_extents, - .draw = ftxfont_draw, - .get_bitmap = ftfont_get_bitmap, - .anchor_point = ftfont_anchor_point, -#ifdef HAVE_LIBOTF - .otf_capability = ftfont_otf_capability, -#endif - .end_for_frame = ftxfont_end_for_frame, -#if defined HAVE_M17N_FLT && defined HAVE_LIBOTF - .shape = ftfont_shape, -#endif -#if defined HAVE_OTF_GET_VARIATION_GLYPHS || defined HAVE_FT_FACE_GETCHARVARIANTINDEX - .get_variation_glyphs = ftfont_variation_glyphs, -#endif - .filter_properties = ftfont_filter_properties, - .combining_capability = ftfont_combining_capability, - }; - -void -syms_of_ftxfont (void) -{ - DEFSYM (Qftx, "ftx"); - pdumper_do_now_and_after_load (syms_of_ftxfont_for_pdumper); -} - -static void -syms_of_ftxfont_for_pdumper (void) -{ - register_font_driver (&ftxfont_driver, NULL); -} diff --git a/src/gnutls.c b/src/gnutls.c index 70176c41cdd..416fb154701 100644 --- a/src/gnutls.c +++ b/src/gnutls.c @@ -230,7 +230,6 @@ DEF_DLL_FN (const char *, gnutls_compression_get_name, DEF_DLL_FN (unsigned, gnutls_safe_renegotiation_status, (gnutls_session_t)); # ifdef HAVE_GNUTLS3 -DEF_DLL_FN (int, gnutls_rnd, (gnutls_rnd_level_t, void *, size_t)); DEF_DLL_FN (const gnutls_mac_algorithm_t *, gnutls_mac_list, (void)); # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE DEF_DLL_FN (size_t, gnutls_mac_get_nonce_size, (gnutls_mac_algorithm_t)); @@ -381,7 +380,6 @@ init_gnutls_functions (void) # endif LOAD_DLL_FN (library, gnutls_safe_renegotiation_status); # ifdef HAVE_GNUTLS3 - LOAD_DLL_FN (library, gnutls_rnd); LOAD_DLL_FN (library, gnutls_mac_list); # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE LOAD_DLL_FN (library, gnutls_mac_get_nonce_size); @@ -519,7 +517,6 @@ init_gnutls_functions (void) # define gnutls_x509_crt_import fn_gnutls_x509_crt_import # define gnutls_x509_crt_init fn_gnutls_x509_crt_init # ifdef HAVE_GNUTLS3 -# define gnutls_rnd fn_gnutls_rnd # define gnutls_mac_list fn_gnutls_mac_list # ifdef HAVE_GNUTLS_MAC_GET_NONCE_SIZE # define gnutls_mac_get_nonce_size fn_gnutls_mac_get_nonce_size @@ -573,14 +570,6 @@ init_gnutls_functions (void) # undef gnutls_free # define gnutls_free (*gnutls_free_func) -/* This wrapper is called from fns.c, which doesn't know about the - LOAD_DLL_FN stuff above. */ -int -w32_gnutls_rnd (gnutls_rnd_level_t level, void *data, size_t len) -{ - return gnutls_rnd (level, data, len); -} - # endif /* WINDOWSNT */ diff --git a/src/gtkutil.c b/src/gtkutil.c index df537c515a2..1fe160acca9 100644 --- a/src/gtkutil.c +++ b/src/gtkutil.c @@ -1411,10 +1411,15 @@ xg_free_frame_widgets (struct frame *f) FRAME_X_WINDOW (f) = 0; /* Set to avoid XDestroyWindow in xterm.c */ FRAME_X_RAW_DRAWABLE (f) = 0; FRAME_GTK_OUTER_WIDGET (f) = 0; + if (x->ttip_widget) + { + /* Remove ttip_lbl from ttip_widget's custom slot before + destroying it, to avoid double-free (Bug#41239). */ + gtk_tooltip_set_custom (x->ttip_widget, NULL); + g_object_unref (G_OBJECT (x->ttip_widget)); + } if (x->ttip_lbl) gtk_widget_destroy (x->ttip_lbl); - if (x->ttip_widget) - g_object_unref (G_OBJECT (x->ttip_widget)); } } @@ -4436,13 +4441,6 @@ xg_tool_bar_callback (GtkWidget *w, gpointer client_data) key = AREF (f->tool_bar_items, idx + TOOL_BAR_ITEM_KEY); XSETFRAME (frame, f); - /* We generate two events here. The first one is to set the prefix - to `(tool_bar)', see keyboard.c. */ - event.kind = TOOL_BAR_EVENT; - event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - event.kind = TOOL_BAR_EVENT; event.frame_or_window = frame; event.arg = key; diff --git a/src/image.c b/src/image.c index 56878bcb8cb..e7e0a93313b 100644 --- a/src/image.c +++ b/src/image.c @@ -24,7 +24,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ /* Include this before including <setjmp.h> to work around bugs with older libpng; see Bug#17429. */ -#if defined HAVE_PNG && !defined HAVE_NS +#if defined HAVE_PNG # include <png.h> #endif @@ -125,6 +125,7 @@ typedef struct ns_bitmap_record Bitmap_Record; #define NO_PIXMAP 0 #define PIX_MASK_RETAIN 0 +#define PIX_MASK_DRAW 1 #endif /* HAVE_NS */ @@ -816,7 +817,6 @@ valid_image_p (Lisp_Object object) return false; } - /* Log error message with format string FORMAT and trailing arguments. Signaling an error, e.g. when an image cannot be loaded, is not a good idea because this would interrupt redisplay, and the error @@ -1004,7 +1004,8 @@ parse_image_spec (Lisp_Object spec, struct image_keyword *keywords, break; } - if (EQ (key, QCtype) && !EQ (type, value)) + if (EQ (key, QCtype) + && !(EQ (type, value) || EQ (type, Qnative_image))) return false; } @@ -1620,7 +1621,7 @@ search_image_cache (struct frame *f, Lisp_Object spec, EMACS_UINT hash) static void uncache_image (struct frame *f, Lisp_Object spec) { - struct image *img = search_image_cache (f, spec, sxhash (spec, 0)); + struct image *img = search_image_cache (f, spec, sxhash (spec)); if (img) { free_image (f, img); @@ -2285,7 +2286,7 @@ lookup_image (struct frame *f, Lisp_Object spec) eassert (valid_image_p (spec)); /* Look up SPEC in the hash table of the image cache. */ - hash = sxhash (spec, 0); + hash = sxhash (spec); img = search_image_cache (f, spec, hash); if (img && img->load_failed_p) { @@ -4572,8 +4573,9 @@ xpm_scan (const char **s, const char *end, const char **beg, ptrdiff_t *len) while (*s < end) { /* Skip white-space. */ - while (*s < end && (c = *(*s)++, c_isspace (c))) - ; + do + c = *(*s)++; + while (c_isspace (c) && *s < end); /* gnus-pointer.xpm uses '-' in its identifier. sb-dir-plus.xpm uses '+' in its identifier. */ @@ -6232,10 +6234,104 @@ pbm_load (struct frame *f, struct image *img) /*********************************************************************** + NATIVE IMAGE HANDLING + ***********************************************************************/ + +#if HAVE_NATIVE_IMAGE_API +static bool +image_can_use_native_api (Lisp_Object type) +{ +# ifdef HAVE_NTGUI + return w32_can_use_native_image_api (type); +# elif defined HAVE_NS + return ns_can_use_native_image_api (type); +# else + return false; +# endif +} + +/* + * These functions are actually defined in the OS-native implementation + * file. Currently, for Windows GDI+ interface, w32image.c, but other + * operating systems can follow suit. + */ + +/* Indices of image specification fields in native format, below. */ +enum native_image_keyword_index +{ + NATIVE_IMAGE_TYPE, + NATIVE_IMAGE_DATA, + NATIVE_IMAGE_FILE, + NATIVE_IMAGE_ASCENT, + NATIVE_IMAGE_MARGIN, + NATIVE_IMAGE_RELIEF, + NATIVE_IMAGE_ALGORITHM, + NATIVE_IMAGE_HEURISTIC_MASK, + NATIVE_IMAGE_MASK, + NATIVE_IMAGE_BACKGROUND, + NATIVE_IMAGE_INDEX, + NATIVE_IMAGE_LAST +}; + +/* Vector of image_keyword structures describing the format + of valid user-defined image specifications. */ +static const struct image_keyword native_image_format[] = +{ + {":type", IMAGE_SYMBOL_VALUE, 1}, + {":data", IMAGE_STRING_VALUE, 0}, + {":file", IMAGE_STRING_VALUE, 0}, + {":ascent", IMAGE_ASCENT_VALUE, 0}, + {":margin", IMAGE_NON_NEGATIVE_INTEGER_VALUE_OR_PAIR, 0}, + {":relief", IMAGE_INTEGER_VALUE, 0}, + {":conversion", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":heuristic-mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":mask", IMAGE_DONT_CHECK_VALUE_TYPE, 0}, + {":background", IMAGE_STRING_OR_NIL_VALUE, 0}, + {":index", IMAGE_NON_NEGATIVE_INTEGER_VALUE, 0} +}; + +/* Return true if OBJECT is a valid native API image specification. */ + +static bool +native_image_p (Lisp_Object object) +{ + struct image_keyword fmt[NATIVE_IMAGE_LAST]; + memcpy (fmt, native_image_format, sizeof fmt); + + if (!parse_image_spec (object, fmt, 10, Qnative_image)) + return 0; + + /* Must specify either the :data or :file keyword. */ + return fmt[NATIVE_IMAGE_FILE].count + fmt[NATIVE_IMAGE_DATA].count == 1; +} + +static bool +native_image_load (struct frame *f, struct image *img) +{ + Lisp_Object image_file = image_spec_value (img->spec, QCfile, NULL); + + if (STRINGP (image_file)) + image_file = image_find_image_file (image_file); + +# ifdef HAVE_NTGUI + return w32_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); +# elif defined HAVE_NS + return ns_load_image (f, img, image_file, + image_spec_value (img->spec, QCdata, NULL)); +# else + return 0; +# endif +} + +#endif /* HAVE_NATIVE_IMAGE_API */ + + +/*********************************************************************** PNG ***********************************************************************/ -#if defined (HAVE_PNG) || defined (HAVE_NS) +#if defined (HAVE_PNG) /* Indices of image specification fields in png_format, below. */ @@ -6286,10 +6382,10 @@ png_image_p (Lisp_Object object) return fmt[PNG_FILE].count + fmt[PNG_DATA].count == 1; } -#endif /* HAVE_PNG || HAVE_NS */ +#endif /* HAVE_PNG */ -#if defined HAVE_PNG && !defined HAVE_NS +#ifdef HAVE_PNG # ifdef WINDOWSNT /* PNG library details. */ @@ -6879,18 +6975,7 @@ png_load (struct frame *f, struct image *img) return png_load_body (f, img, &c); } -#elif defined HAVE_NS - -static bool -png_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} - - -#endif /* HAVE_NS */ +#endif /* HAVE_PNG */ @@ -6898,7 +6983,7 @@ png_load (struct frame *f, struct image *img) JPEG ***********************************************************************/ -#if defined (HAVE_JPEG) || defined (HAVE_NS) +#if defined (HAVE_JPEG) /* Indices of image specification fields in gs_format, below. */ @@ -6950,7 +7035,7 @@ jpeg_image_p (Lisp_Object object) return fmt[JPEG_FILE].count + fmt[JPEG_DATA].count == 1; } -#endif /* HAVE_JPEG || HAVE_NS */ +#endif /* HAVE_JPEG */ #ifdef HAVE_JPEG @@ -7452,18 +7537,6 @@ jpeg_load (struct frame *f, struct image *img) return jpeg_load_body (f, img, &mgr); } -#else /* HAVE_JPEG */ - -#ifdef HAVE_NS -static bool -jpeg_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} -#endif /* HAVE_NS */ - #endif /* !HAVE_JPEG */ @@ -7472,7 +7545,7 @@ jpeg_load (struct frame *f, struct image *img) TIFF ***********************************************************************/ -#if defined (HAVE_TIFF) || defined (HAVE_NS) +#if defined (HAVE_TIFF) /* Indices of image specification fields in tiff_format, below. */ @@ -7525,7 +7598,7 @@ tiff_image_p (Lisp_Object object) return fmt[TIFF_FILE].count + fmt[TIFF_DATA].count == 1; } -#endif /* HAVE_TIFF || HAVE_NS */ +#endif /* HAVE_TIFF */ #ifdef HAVE_TIFF @@ -7893,16 +7966,6 @@ tiff_load (struct frame *f, struct image *img) return 1; } -#elif defined HAVE_NS - -static bool -tiff_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} - #endif @@ -7911,7 +7974,7 @@ tiff_load (struct frame *f, struct image *img) GIF ***********************************************************************/ -#if defined (HAVE_GIF) || defined (HAVE_NS) +#if defined (HAVE_GIF) /* Indices of image specification fields in gif_format, below. */ @@ -8211,7 +8274,10 @@ gif_load (struct frame *f, struct image *img) rc = DGifSlurp (gif); if (rc == GIF_ERROR || gif->ImageCount <= 0) { - image_error ("Error reading `%s'", img->spec); + if (NILP (specified_data)) + image_error ("Error reading `%s'", img->spec); + else + image_error ("Error reading GIF data"); gif_close (gif, NULL); return 0; } @@ -8490,18 +8556,6 @@ gif_load (struct frame *f, struct image *img) return 1; } -#else /* !HAVE_GIF */ - -#ifdef HAVE_NS -static bool -gif_load (struct frame *f, struct image *img) -{ - return ns_load_image (f, img, - image_spec_value (img->spec, QCfile, NULL), - image_spec_value (img->spec, QCdata, NULL)); -} -#endif /* HAVE_NS */ - #endif /* HAVE_GIF */ @@ -10132,6 +10186,12 @@ initialize_image_type (struct image_type const *type) { #ifdef WINDOWSNT Lisp_Object typesym = builtin_lisp_symbol (type->type); + +# if HAVE_NATIVE_IMAGE_API + if (image_can_use_native_api (typesym)) + return true; +# endif + Lisp_Object tested = Fassq (typesym, Vlibrary_cache); /* If we failed to load the library before, don't try again. */ if (CONSP (tested)) @@ -10164,19 +10224,19 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qsvg), svg_image_p, svg_load, image_clear_image, IMAGE_TYPE_INIT (init_svg_functions) }, #endif -#if defined HAVE_PNG || defined HAVE_NS +#if defined HAVE_PNG { SYMBOL_INDEX (Qpng), png_image_p, png_load, image_clear_image, IMAGE_TYPE_INIT (init_png_functions) }, #endif -#if defined HAVE_GIF || defined HAVE_NS +#if defined HAVE_GIF { SYMBOL_INDEX (Qgif), gif_image_p, gif_load, gif_clear_image, IMAGE_TYPE_INIT (init_gif_functions) }, #endif -#if defined HAVE_TIFF || defined HAVE_NS +#if defined HAVE_TIFF { SYMBOL_INDEX (Qtiff), tiff_image_p, tiff_load, image_clear_image, IMAGE_TYPE_INIT (init_tiff_functions) }, #endif -#if defined HAVE_JPEG || defined HAVE_NS +#if defined HAVE_JPEG { SYMBOL_INDEX (Qjpeg), jpeg_image_p, jpeg_load, image_clear_image, IMAGE_TYPE_INIT (init_jpeg_functions) }, #endif @@ -10188,12 +10248,23 @@ static struct image_type const image_types[] = { SYMBOL_INDEX (Qpbm), pbm_image_p, pbm_load, image_clear_image }, }; +#if HAVE_NATIVE_IMAGE_API +struct image_type native_image_type = + { SYMBOL_INDEX (Qnative_image), native_image_p, native_image_load, + image_clear_image }; +#endif + /* Look up image type TYPE, and return a pointer to its image_type structure. Return 0 if TYPE is not a known image type. */ static struct image_type const * lookup_image_type (Lisp_Object type) { +#if HAVE_NATIVE_IMAGE_API + if (image_can_use_native_api (type)) + return &native_image_type; +#endif + for (int i = 0; i < ARRAYELTS (image_types); i++) { struct image_type const *r = &image_types[i]; @@ -10315,22 +10386,22 @@ non-numeric, there is no explicit limit on the size of images. */); add_image_type (Qxpm); #endif -#if defined (HAVE_JPEG) || defined (HAVE_NS) +#if defined (HAVE_JPEG) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qjpeg, "jpeg"); add_image_type (Qjpeg); #endif -#if defined (HAVE_TIFF) || defined (HAVE_NS) +#if defined (HAVE_TIFF) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qtiff, "tiff"); add_image_type (Qtiff); #endif -#if defined (HAVE_GIF) || defined (HAVE_NS) +#if defined (HAVE_GIF) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qgif, "gif"); add_image_type (Qgif); #endif -#if defined (HAVE_PNG) || defined (HAVE_NS) +#if defined (HAVE_PNG) || defined (HAVE_NATIVE_IMAGE_API) DEFSYM (Qpng, "png"); add_image_type (Qpng); #endif @@ -10354,6 +10425,14 @@ non-numeric, there is no explicit limit on the size of images. */); #endif /* HAVE_NTGUI */ #endif /* HAVE_RSVG */ +#if HAVE_NATIVE_IMAGE_API + DEFSYM (Qnative_image, "native-image"); +# ifdef HAVE_NTGUI + DEFSYM (Qgdiplus, "gdiplus"); + DEFSYM (Qshlwapi, "shlwapi"); +# endif +#endif + defsubr (&Sinit_image_library); #ifdef HAVE_IMAGEMAGICK defsubr (&Simagemagick_types); diff --git a/src/indent.c b/src/indent.c index 939e5931db0..581323b91ee 100644 --- a/src/indent.c +++ b/src/indent.c @@ -285,9 +285,7 @@ skip_invisible (ptrdiff_t pos, ptrdiff_t *next_boundary_p, ptrdiff_t to, Lisp_Ob #define MULTIBYTE_BYTES_WIDTH(p, dp, bytes, width) \ do { \ - int ch; \ - \ - ch = STRING_CHAR_AND_LENGTH (p, bytes); \ + int ch = string_char_and_length (p, &(bytes)); \ if (BYTES_BY_CHAR_HEAD (*p) != bytes) \ width = bytes * 4; \ else \ @@ -942,7 +940,7 @@ position_indentation (ptrdiff_t pos_byte) if (CHAR_HAS_CATEGORY (c, ' ')) { column++; - INC_POS (pos_byte); + pos_byte += next_char_len (pos_byte); p = BYTE_POS_ADDR (pos_byte); } else @@ -961,7 +959,7 @@ indented_beyond_p (ptrdiff_t pos, ptrdiff_t pos_byte, EMACS_INT column) { while (pos > BEGV && FETCH_BYTE (pos_byte) == '\n') { - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); pos = find_newline (pos, pos_byte, BEGV, BEGV_BYTE, -1, NULL, &pos_byte, 0); } @@ -1010,7 +1008,7 @@ The return value is the current column. */) int c; ptrdiff_t pos_byte = PT_BYTE; - DEC_POS (pos_byte); + pos_byte -= prev_char_len (pos_byte); c = FETCH_CHAR (pos_byte); if (c == '\t' && prev_col < goal) { @@ -1605,7 +1603,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, { pos = find_before_next_newline (pos, to, 1, &pos_byte); if (pos < to) - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); rarely_quit (++quit_count); } while (pos < to @@ -1618,7 +1616,7 @@ compute_motion (ptrdiff_t from, ptrdiff_t frombyte, EMACS_INT fromvpos, if (hpos >= width) hpos = width; } - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); /* We have skipped the invis text, but not the newline after. */ } @@ -1820,8 +1818,8 @@ visible section of the buffer, and pass LINE and COL as TOPOS. */) static struct position val_vmotion; struct position * -vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, - register EMACS_INT vtarget, struct window *w) +vmotion (ptrdiff_t from, ptrdiff_t from_byte, + EMACS_INT vtarget, struct window *w) { ptrdiff_t hscroll = w->hscroll; struct position pos; @@ -1862,7 +1860,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, Lisp_Object propval; prevline = from; - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); while (prevline > BEGV @@ -1875,7 +1873,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) { - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, @@ -1925,7 +1923,7 @@ vmotion (register ptrdiff_t from, register ptrdiff_t from_byte, text_prop_object), TEXT_PROP_MEANS_INVISIBLE (propval)))) { - DEC_BOTH (prevline, bytepos); + dec_both (&prevline, &bytepos); prevline = find_newline_no_quit (prevline, bytepos, -1, &bytepos); } pos = *compute_motion (prevline, bytepos, 0, lmargin, 0, from, @@ -2091,15 +2089,15 @@ whether or not it is currently displayed in some window. */) struct it it; struct text_pos pt; struct window *w; - Lisp_Object lcols; + Lisp_Object lcols = Qnil; void *itdata = NULL; ptrdiff_t count = SPECPDL_INDEX (); /* Allow LINES to be of the form (HPOS . VPOS) aka (COLUMNS . LINES). */ - bool lcols_given = CONSP (lines); - if (lcols_given) + if (CONSP (lines)) { lcols = XCAR (lines); + CHECK_NUMBER (lcols); lines = XCDR (lines); } @@ -2279,9 +2277,9 @@ whether or not it is currently displayed in some window. */) overshoot_handled = 1; } - if (lcols_given) + if (!NILP (lcols)) to_x = - window_column_x (w, window, extract_float (lcols), lcols) + window_column_x (w, window, XFLOATINT (lcols), lcols) + lnum_pixel_width; if (nlines <= 0) { @@ -2332,7 +2330,7 @@ whether or not it is currently displayed in some window. */) /* Move to the goal column, if one was specified. If the window was originally hscrolled, the goal column is interpreted as an addition to the hscroll amount. */ - if (lcols_given) + if (!NILP (lcols)) { move_it_in_display_line (&it, ZV, first_x + to_x, MOVE_TO_X); /* If we find ourselves in the middle of an overlay string diff --git a/src/insdel.c b/src/insdel.c index dfa1cc311ca..c37b0710783 100644 --- a/src/insdel.c +++ b/src/insdel.c @@ -382,10 +382,10 @@ count_bytes (ptrdiff_t pos, ptrdiff_t bytepos, ptrdiff_t endpos) if (pos <= endpos) for ( ; pos < endpos; pos++) - INC_POS (bytepos); + bytepos += next_char_len (bytepos); else for ( ; pos > endpos; pos--) - DEC_POS (bytepos); + bytepos -= prev_char_len (bytepos); return bytepos; } @@ -626,8 +626,7 @@ copy_text (const unsigned char *from_addr, unsigned char *to_addr, while (bytes_left > 0) { - int thislen, c; - c = STRING_CHAR_AND_LENGTH (from_addr, thislen); + int thislen, c = string_char_and_length (from_addr, &thislen); if (! ASCII_CHAR_P (c)) c &= 0xFF; *to_addr++ = c; diff --git a/src/intervals.c b/src/intervals.c index 585ef18bd2e..0257591a142 100644 --- a/src/intervals.c +++ b/src/intervals.c @@ -117,10 +117,11 @@ create_root_interval (Lisp_Object parent) /* Make the interval TARGET have exactly the properties of SOURCE. */ void -copy_properties (register INTERVAL source, register INTERVAL target) +copy_properties (INTERVAL source, INTERVAL target) { if (DEFAULT_INTERVAL_P (source) && DEFAULT_INTERVAL_P (target)) return; + eassume (source && target); COPY_INTERVAL_CACHE (source, target); set_interval_plist (target, Fcopy_sequence (source->plist)); @@ -298,7 +299,7 @@ rotate_right (INTERVAL A) set_interval_parent (c, A); /* A's total length is decreased by the length of B and its left child. */ - A->total_length -= B->total_length - TOTAL_LENGTH (c); + A->total_length -= TOTAL_LENGTH (B) - TOTAL_LENGTH0 (c); eassert (TOTAL_LENGTH (A) > 0); eassert (LENGTH (A) > 0); @@ -349,7 +350,7 @@ rotate_left (INTERVAL A) set_interval_parent (c, A); /* A's total length is decreased by the length of B and its right child. */ - A->total_length -= B->total_length - TOTAL_LENGTH (c); + A->total_length -= TOTAL_LENGTH (B) - TOTAL_LENGTH0 (c); eassert (TOTAL_LENGTH (A) > 0); eassert (LENGTH (A) > 0); @@ -723,13 +724,13 @@ previous_interval (register INTERVAL interval) i->position - LEFT_TOTAL_LENGTH (i) \ - LENGTH (INTERVAL_PARENT (i)) -/* Find the interval containing POS, given some non-NULL INTERVAL in +/* Find the interval containing POS, given some interval I in the same tree. Note that we update interval->position in each interval we traverse, assuming it is already correctly set for the argument I. We don't assume that any other interval already has a correctly set ->position. */ INTERVAL -update_interval (register INTERVAL i, ptrdiff_t pos) +update_interval (INTERVAL i, ptrdiff_t pos) { if (!i) return NULL; @@ -739,7 +740,7 @@ update_interval (register INTERVAL i, ptrdiff_t pos) if (pos < i->position) { /* Move left. */ - if (pos >= i->position - TOTAL_LENGTH (i->left)) + if (pos >= i->position - LEFT_TOTAL_LENGTH (i)) { i->left->position = i->position - TOTAL_LENGTH (i->left) + LEFT_TOTAL_LENGTH (i->left); @@ -757,7 +758,7 @@ update_interval (register INTERVAL i, ptrdiff_t pos) else if (pos >= INTERVAL_LAST_POS (i)) { /* Move right. */ - if (pos < INTERVAL_LAST_POS (i) + TOTAL_LENGTH (i->right)) + if (pos < INTERVAL_LAST_POS (i) + RIGHT_TOTAL_LENGTH (i)) { i->right->position = INTERVAL_LAST_POS (i) + LEFT_TOTAL_LENGTH (i->right); diff --git a/src/intervals.h b/src/intervals.h index a93b10e9fff..9a7ba910a10 100644 --- a/src/intervals.h +++ b/src/intervals.h @@ -96,24 +96,27 @@ struct interval /* True if this interval has both left and right children. */ #define BOTH_KIDS_P(i) ((i)->left != NULL && (i)->right != NULL) -/* The total size of all text represented by this interval and all its - children in the tree. This is zero if the interval is null. */ -#define TOTAL_LENGTH(i) ((i) == NULL ? 0 : (i)->total_length) +/* The total size of all text represented by the nonnull interval I + and all its children in the tree. */ +#define TOTAL_LENGTH(i) ((i)->total_length) + +/* Likewise, but also defined to be zero if I is null. */ +#define TOTAL_LENGTH0(i) ((i) ? TOTAL_LENGTH (i) : 0) /* The size of text represented by this interval alone. */ -#define LENGTH(i) ((i)->total_length \ - - TOTAL_LENGTH ((i)->right) \ - - TOTAL_LENGTH ((i)->left)) +#define LENGTH(i) (TOTAL_LENGTH (i) \ + - RIGHT_TOTAL_LENGTH (i) \ + - LEFT_TOTAL_LENGTH (i)) /* The position of the character just past the end of I. Note that the position cache i->position must be valid for this to work. */ #define INTERVAL_LAST_POS(i) ((i)->position + LENGTH (i)) /* The total size of the left subtree of this interval. */ -#define LEFT_TOTAL_LENGTH(i) ((i)->left ? (i)->left->total_length : 0) +#define LEFT_TOTAL_LENGTH(i) TOTAL_LENGTH0 ((i)->left) /* The total size of the right subtree of this interval. */ -#define RIGHT_TOTAL_LENGTH(i) ((i)->right ? (i)->right->total_length : 0) +#define RIGHT_TOTAL_LENGTH(i) TOTAL_LENGTH0 ((i)->right) /* These macros are for dealing with the interval properties. */ @@ -234,7 +237,7 @@ set_interval_plist (INTERVAL i, Lisp_Object plist) /* Declared in alloc.c. */ -extern INTERVAL make_interval (void); +extern INTERVAL make_interval (void) ATTRIBUTE_RETURNS_NONNULL; /* Declared in intervals.c. */ @@ -246,7 +249,8 @@ extern void traverse_intervals (INTERVAL, ptrdiff_t, Lisp_Object); extern void traverse_intervals_noorder (INTERVAL, void (*) (INTERVAL, void *), void *); -extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t); +extern INTERVAL split_interval_right (INTERVAL, ptrdiff_t) + ATTRIBUTE_RETURNS_NONNULL; extern INTERVAL split_interval_left (INTERVAL, ptrdiff_t); extern INTERVAL find_interval (INTERVAL, ptrdiff_t); extern INTERVAL next_interval (INTERVAL); diff --git a/src/json.c b/src/json.c index 4648cb4c3b7..814afc6d741 100644 --- a/src/json.c +++ b/src/json.c @@ -1123,7 +1123,6 @@ syms_of_json (void) DEFSYM (Qstring_without_embedded_nulls_p, "string-without-embedded-nulls-p"); DEFSYM (Qjson_value_p, "json-value-p"); - DEFSYM (Qutf_8_string_p, "utf-8-string-p"); DEFSYM (Qjson_error, "json-error"); DEFSYM (Qjson_out_of_memory, "json-out-of-memory"); diff --git a/src/keyboard.c b/src/keyboard.c index 5f136f03ecf..5fa58abce1d 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -2279,7 +2279,7 @@ read_decoded_event_from_main_queue (struct timespec *end_time, eassert (coding->carryover_bytes == 0); n = 0; while (n < coding->produced_char) - events[n++] = make_fixnum (STRING_CHAR_ADVANCE (p)); + events[n++] = make_fixnum (string_char_advance (&p)); } } } @@ -2901,6 +2901,12 @@ read_char (int commandflag, Lisp_Object map, example banishing the mouse under mouse-avoidance-mode. */ timer_resume_idle (); +#ifdef HAVE_NS + if (CONSP (c) + && (EQ (XCAR (c), intern ("ns-unput-working-text")))) + input_was_pending = input_pending; +#endif + if (current_buffer != prev_buffer) { /* The command may have changed the keymaps. Pretend there @@ -2921,13 +2927,11 @@ read_char (int commandflag, Lisp_Object map, goto exit; if ((STRINGP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFIXNAT (c), <, - SCHARS (KVAR (current_kboard, - Vkeyboard_translate_table)))) + && XFIXNAT (c) < SCHARS (KVAR (current_kboard, + Vkeyboard_translate_table))) || (VECTORP (KVAR (current_kboard, Vkeyboard_translate_table)) - && UNSIGNED_CMP (XFIXNAT (c), <, - ASIZE (KVAR (current_kboard, - Vkeyboard_translate_table)))) + && XFIXNAT (c) < ASIZE (KVAR (current_kboard, + Vkeyboard_translate_table))) || (CHAR_TABLE_P (KVAR (current_kboard, Vkeyboard_translate_table)) && CHARACTERP (c))) { @@ -5992,24 +5996,14 @@ make_lispy_event (struct input_event *event) return list2 (Qselect_window, list1 (event->frame_or_window)); case TAB_BAR_EVENT: - if (EQ (event->arg, event->frame_or_window)) - /* This is the prefix key. We translate this to - `(tab_bar)' because the code in keyboard.c for tab bar - events, which we use, relies on this. */ - return list1 (Qtab_bar); - else if (SYMBOLP (event->arg)) - return apply_modifiers (event->modifiers, event->arg); - return event->arg; - case TOOL_BAR_EVENT: - if (EQ (event->arg, event->frame_or_window)) - /* This is the prefix key. We translate this to - `(tool_bar)' because the code in keyboard.c for tool bar - events, which we use, relies on this. */ - return list1 (Qtool_bar); - else if (SYMBOLP (event->arg)) - return apply_modifiers (event->modifiers, event->arg); - return event->arg; + { + Lisp_Object res = event->arg; + Lisp_Object location + = event->kind == TAB_BAR_EVENT ? Qtab_bar : Qtool_bar; + if (SYMBOLP (res)) res = apply_modifiers (event->modifiers, res); + return list2 (res, list2 (event->frame_or_window, location)); + } case USER_SIGNAL_EVENT: /* A user signal. */ @@ -8308,7 +8302,7 @@ append_tab_bar_item (void) /* Append entries from tab_bar_item_properties to the end of tab_bar_items_vector. */ vcopy (tab_bar_items_vector, ntab_bar_items, - XVECTOR (tab_bar_item_properties)->contents, TAB_BAR_ITEM_NSLOTS); + xvector_contents (tab_bar_item_properties), TAB_BAR_ITEM_NSLOTS); ntab_bar_items += TAB_BAR_ITEM_NSLOTS; } @@ -8785,7 +8779,7 @@ append_tool_bar_item (void) /* Append entries from tool_bar_item_properties to the end of tool_bar_items_vector. */ vcopy (tool_bar_items_vector, ntool_bar_items, - XVECTOR (tool_bar_item_properties)->contents, TOOL_BAR_ITEM_NSLOTS); + xvector_contents (tool_bar_item_properties), TOOL_BAR_ITEM_NSLOTS); ntool_bar_items += TOOL_BAR_ITEM_NSLOTS; } @@ -10472,9 +10466,8 @@ Internal use only. */) this_command_key_count = 0; this_single_command_key_start = 0; - int charidx = 0, byteidx = 0; - int key0; - FETCH_STRING_CHAR_ADVANCE (key0, keys, charidx, byteidx); + ptrdiff_t charidx = 0, byteidx = 0; + int key0 = fetch_string_char_advance (keys, &charidx, &byteidx); if (CHAR_BYTE8_P (key0)) key0 = CHAR_TO_BYTE8 (key0); @@ -10486,8 +10479,7 @@ Internal use only. */) add_command_key (make_fixnum (key0)); for (ptrdiff_t i = 1; i < SCHARS (keys); i++) { - int key_i; - FETCH_STRING_CHAR_ADVANCE (key_i, keys, charidx, byteidx); + int key_i = fetch_string_char_advance (keys, &charidx, &byteidx); if (CHAR_BYTE8_P (key_i)) key_i = CHAR_TO_BYTE8 (key_i); add_command_key (make_fixnum (key_i)); diff --git a/src/keymap.c b/src/keymap.c index cfba98c72f2..d98b27b7a1b 100644 --- a/src/keymap.c +++ b/src/keymap.c @@ -1949,8 +1949,7 @@ then the value includes only maps for prefixes that start with PREFIX. */) for (ptrdiff_t i = 0; i < SCHARS (prefix); ) { ptrdiff_t i_before = i; - int c; - FETCH_STRING_CHAR_ADVANCE (c, prefix, i, i_byte); + int c = fetch_string_char_advance (prefix, &i, &i_byte); if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) c ^= 0200 | meta_modifier; ASET (copy, i_before, make_fixnum (c)); @@ -2006,23 +2005,16 @@ For an approximate inverse of this, see `kbd'. */) (Lisp_Object keys, Lisp_Object prefix) { ptrdiff_t len = 0; - EMACS_INT i; - ptrdiff_t i_byte; Lisp_Object *args; - EMACS_INT size = XFIXNUM (Flength (keys)); - Lisp_Object list; + EMACS_INT nkeys = XFIXNUM (Flength (keys)); + EMACS_INT nprefix = XFIXNUM (Flength (prefix)); Lisp_Object sep = build_string (" "); - Lisp_Object key; - Lisp_Object result; - bool add_meta = 0; + bool add_meta = false; USE_SAFE_ALLOCA; - if (!NILP (prefix)) - size += XFIXNUM (Flength (prefix)); - /* This has one extra element at the end that we don't pass to Fconcat. */ - EMACS_INT size4; - if (INT_MULTIPLY_WRAPV (size, 4, &size4)) + ptrdiff_t size4; + if (INT_MULTIPLY_WRAPV (nkeys + nprefix, 4, &size4)) memory_full (SIZE_MAX); SAFE_ALLOCA_LISP (args, size4); @@ -2030,82 +2022,76 @@ For an approximate inverse of this, see `kbd'. */) (mapconcat 'single-key-description keys " ") but we shouldn't use mapconcat because it can do GC. */ - next_list: - if (!NILP (prefix)) - list = prefix, prefix = Qnil; - else if (!NILP (keys)) - list = keys, keys = Qnil; - else + Lisp_Object lists[2] = { prefix, keys }; + ptrdiff_t listlens[2] = { nprefix, nkeys }; + for (int li = 0; li < ARRAYELTS (lists); li++) { - if (add_meta) - { - args[len] = Fsingle_key_description (meta_prefix_char, Qnil); - result = Fconcat (len + 1, args); - } - else if (len == 0) - result = empty_unibyte_string; - else - result = Fconcat (len - 1, args); - SAFE_FREE (); - return result; - } + Lisp_Object list = lists[li]; + ptrdiff_t listlen = listlens[li], i_byte = 0; - if (STRINGP (list)) - size = SCHARS (list); - else if (VECTORP (list)) - size = ASIZE (list); - else if (CONSP (list)) - size = list_length (list); - else - wrong_type_argument (Qarrayp, list); + if (! (NILP (list) || STRINGP (list) || VECTORP (list) || CONSP (list))) + wrong_type_argument (Qarrayp, list); - i = i_byte = 0; - - while (i < size) - { - if (STRINGP (list)) + for (ptrdiff_t i = 0; i < listlen; ) { - int c; - FETCH_STRING_CHAR_ADVANCE (c, list, i, i_byte); - if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) - c ^= 0200 | meta_modifier; - XSETFASTINT (key, c); - } - else if (VECTORP (list)) - { - key = AREF (list, i); i++; - } - else - { - key = XCAR (list); - list = XCDR (list); - i++; - } - - if (add_meta) - { - if (!FIXNUMP (key) - || EQ (key, meta_prefix_char) - || (XFIXNUM (key) & meta_modifier)) + Lisp_Object key; + if (STRINGP (list)) { - args[len++] = Fsingle_key_description (meta_prefix_char, Qnil); - args[len++] = sep; - if (EQ (key, meta_prefix_char)) - continue; + int c = fetch_string_char_advance (list, &i, &i_byte); + if (SINGLE_BYTE_CHAR_P (c) && (c & 0200)) + c ^= 0200 | meta_modifier; + key = make_fixnum (c); + } + else if (VECTORP (list)) + { + key = AREF (list, i); + i++; } else - XSETINT (key, XFIXNUM (key) | meta_modifier); - add_meta = 0; - } - else if (EQ (key, meta_prefix_char)) - { - add_meta = 1; - continue; + { + key = XCAR (list); + list = XCDR (list); + i++; + } + + if (add_meta) + { + if (!FIXNUMP (key) + || EQ (key, meta_prefix_char) + || (XFIXNUM (key) & meta_modifier)) + { + args[len++] = Fsingle_key_description (meta_prefix_char, + Qnil); + args[len++] = sep; + if (EQ (key, meta_prefix_char)) + continue; + } + else + key = make_fixnum (XFIXNUM (key) | meta_modifier); + add_meta = false; + } + else if (EQ (key, meta_prefix_char)) + { + add_meta = true; + continue; + } + args[len++] = Fsingle_key_description (key, Qnil); + args[len++] = sep; } - args[len++] = Fsingle_key_description (key, Qnil); - args[len++] = sep; } - goto next_list; + + Lisp_Object result; + if (add_meta) + { + args[len] = Fsingle_key_description (meta_prefix_char, Qnil); + result = Fconcat (len + 1, args); + } + else if (len == 0) + result = empty_unibyte_string; + else + result = Fconcat (len - 1, args); + SAFE_FREE (); + return result; } @@ -2282,12 +2268,6 @@ See `text-char-description' for describing character codes. */) static char * push_text_char_description (register unsigned int c, register char *p) { - if (c >= 0200) - { - *p++ = 'M'; - *p++ = '-'; - c -= 0200; - } if (c < 040) { *p++ = '^'; @@ -2316,23 +2296,22 @@ characters into "C-char", and uses the 2**27 bit for Meta. See Info node `(elisp)Describing Characters' for examples. */) (Lisp_Object character) { - /* Currently MAX_MULTIBYTE_LENGTH is 4 (< 6). */ - char str[6]; - int c; - CHECK_CHARACTER (character); - c = XFIXNUM (character); + int c = XFIXNUM (character); if (!ASCII_CHAR_P (c)) { + char str[MAX_MULTIBYTE_LENGTH]; int len = CHAR_STRING (c, (unsigned char *) str); return make_multibyte_string (str, 1, len); } - - *push_text_char_description (c & 0377, str) = 0; - - return build_string (str); + else + { + char desc[4]; + int len = push_text_char_description (c, desc) - desc; + return make_string (desc, len); + } } static int where_is_preferred_modifier; diff --git a/src/lcms.c b/src/lcms.c index a74c5539860..924bdd299dc 100644 --- a/src/lcms.c +++ b/src/lcms.c @@ -254,8 +254,7 @@ parse_viewing_conditions (Lisp_Object view, const cmsCIEXYZ *wp, #define PARSE_VIEW_CONDITION_INT(field) \ if (CONSP (view) && FIXNATP (XCAR (view))) \ { \ - CHECK_RANGED_INTEGER (XCAR (view), 1, 4); \ - vc->field = XFIXNUM (XCAR (view)); \ + vc->field = check_integer_range (XCAR (view), 1, 4); \ view = XCDR (view); \ } \ else \ @@ -317,7 +316,7 @@ jab_to_jch (const lcmsJab_t *jab, cmsJCh *jch, double FL, double c1, double c2) } DEFUN ("lcms-xyz->jch", Flcms_xyz_to_jch, Slcms_xyz_to_jch, 1, 3, 0, - doc: /* Convert CIE CAM02 JCh to CIE XYZ. + doc: /* Convert CIE XYZ to CIE CAM02 JCh. COLOR is a list (X Y Z), with Y scaled about unity. Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs', which see. */) @@ -353,7 +352,7 @@ which see. */) } DEFUN ("lcms-jch->xyz", Flcms_jch_to_xyz, Slcms_jch_to_xyz, 1, 3, 0, - doc: /* Convert CIE XYZ to CIE CAM02 JCh. + doc: /* Convert CIE CAM02 JCh to CIE XYZ. COLOR is a list (J C h), where lightness of white is equal to 100, and hue is given in degrees. Optional arguments WHITEPOINT and VIEW are the same as in `lcms-cam02-ucs', diff --git a/src/lisp.h b/src/lisp.h index 92294ac1d33..7b4f484b9b7 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -251,12 +251,6 @@ DEFINE_GDB_SYMBOL_BEGIN (EMACS_INT, VALMASK) # define VALMASK (USE_LSB_TAG ? - (1 << GCTYPEBITS) : VAL_MAX) DEFINE_GDB_SYMBOL_END (VALMASK) -#if !USE_LSB_TAG && !defined WIDE_EMACS_INT -# error "USE_LSB_TAG not supported on this platform; please report this." \ - "Try 'configure --with-wide-int' to work around the problem." -error !; -#endif - /* Minimum alignment requirement for Lisp objects, imposed by the internal representation of tagged pointers. It is 2**GCTYPEBITS if USE_LSB_TAG, 1 otherwise. It must be a literal integer constant, @@ -277,7 +271,8 @@ error !; allocation in a containing union that has GCALIGNED_UNION_MEMBER) and does not contain a GC-aligned struct or union, putting GCALIGNED_STRUCT after its closing '}' can help the compiler - generate better code. + generate better code. Also, such structs should be added to the + emacs_align_type union in alloc.c. Although these macros are reasonably portable, they are not guaranteed on non-GCC platforms, as C11 does not require support @@ -331,8 +326,8 @@ typedef EMACS_INT Lisp_Word; used elsewhere. FIXME: Remove the lisp_h_OP macros, and define just the inline OP - functions, once "gcc -Og" (new to GCC 4.8) works well enough for - Emacs developers. Maybe in the year 2020. See Bug#11935. + functions, once "gcc -Og" (new to GCC 4.8) or equivalent works well + enough for Emacs developers. Maybe in the year 2025. See Bug#11935. For the macros that have corresponding functions (defined later), see these functions for commentary. */ @@ -411,15 +406,19 @@ typedef EMACS_INT Lisp_Word; # define lisp_h_XTYPE(a) ((enum Lisp_Type) (XLI (a) & ~VALMASK)) #endif -/* When compiling via gcc -O0, define the key operations as macros, as - Emacs is too slow otherwise. To disable this optimization, compile - with -DINLINING=false. */ -#if (defined __NO_INLINE__ \ - && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__ \ - && ! (defined INLINING && ! INLINING)) -# define DEFINE_KEY_OPS_AS_MACROS true -#else -# define DEFINE_KEY_OPS_AS_MACROS false +/* When DEFINE_KEY_OPS_AS_MACROS, define key operations as macros to + cajole the compiler into inlining them; otherwise define them as + inline functions as this is cleaner and can be more efficient. + The default is true if the compiler is GCC-like and if function + inlining is disabled because the compiler is not optimizing or is + optimizing for size. Otherwise the default is false. */ +#ifndef DEFINE_KEY_OPS_AS_MACROS +# if (defined __NO_INLINE__ \ + && ! defined __OPTIMIZE__ && ! defined __OPTIMIZE_SIZE__) +# define DEFINE_KEY_OPS_AS_MACROS true +# else +# define DEFINE_KEY_OPS_AS_MACROS false +# endif #endif #if DEFINE_KEY_OPS_AS_MACROS @@ -481,6 +480,7 @@ enum Lisp_Type Lisp_Symbol = 0, /* Type 1 is currently unused. */ + Lisp_Type_Unused0 = 1, /* Fixnum. XFIXNUM (obj) is the integer value. */ Lisp_Int0 = 2, @@ -584,15 +584,19 @@ INLINE void set_sub_char_table_contents (Lisp_Object, ptrdiff_t, Lisp_Object); /* Defined in bignum.c. */ -extern double bignum_to_double (Lisp_Object); +extern int check_int_nonnegative (Lisp_Object); +extern intmax_t check_integer_range (Lisp_Object, intmax_t, intmax_t); +extern double bignum_to_double (Lisp_Object) ATTRIBUTE_CONST; extern Lisp_Object make_bigint (intmax_t); extern Lisp_Object make_biguint (uintmax_t); +extern uintmax_t check_uinteger_max (Lisp_Object, uintmax_t); /* Defined in chartab.c. */ -extern Lisp_Object char_table_ref (Lisp_Object, int); +extern Lisp_Object char_table_ref (Lisp_Object, int) ATTRIBUTE_PURE; extern void char_table_set (Lisp_Object, int, Lisp_Object); /* Defined in data.c. */ +extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID wrong_type_argument (Lisp_Object, Lisp_Object); extern Lisp_Object default_value (Lisp_Object symbol); @@ -1070,7 +1074,7 @@ DEFINE_GDB_SYMBOL_END (PSEUDOVECTOR_FLAG) with PVEC_TYPE_MASK to indicate the actual type. */ enum pvec_type { - PVEC_NORMAL_VECTOR, + PVEC_NORMAL_VECTOR, /* Should be first, for sxhash_obj. */ PVEC_FREE, PVEC_BIGNUM, PVEC_MARKER, @@ -1095,7 +1099,7 @@ enum pvec_type PVEC_CONDVAR, PVEC_MODULE_FUNCTION, - /* These should be last, check internal_equal to see why. */ + /* These should be last, for internal_equal and sxhash_obj. */ PVEC_COMPILED, PVEC_CHAR_TABLE, PVEC_SUB_CHAR_TABLE, @@ -1332,7 +1336,6 @@ dead_object (void) #define XSETWINDOW(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_WINDOW)) #define XSETTERMINAL(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_TERMINAL)) #define XSETSUBR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_SUBR)) -#define XSETCOMPILED(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_COMPILED)) #define XSETBUFFER(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BUFFER)) #define XSETCHAR_TABLE(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_CHAR_TABLE)) #define XSETBOOL_VECTOR(a, b) (XSETPSEUDOVECTOR (a, b, PVEC_BOOL_VECTOR)) @@ -1669,6 +1672,13 @@ ASIZE (Lisp_Object array) } INLINE ptrdiff_t +gc_asize (Lisp_Object array) +{ + /* Like ASIZE, but also can be used in the garbage collector. */ + return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; +} + +INLINE ptrdiff_t PVSIZE (Lisp_Object pv) { return ASIZE (pv) & PSEUDOVECTOR_SIZE_MASK; @@ -1850,22 +1860,17 @@ bool_vector_set (Lisp_Object a, EMACS_INT i, bool b) INLINE Lisp_Object AREF (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx < gc_asize (array)); return XVECTOR (array)->contents[idx]; } INLINE Lisp_Object * aref_addr (Lisp_Object array, ptrdiff_t idx) { + eassert (0 <= idx && idx <= gc_asize (array)); return & XVECTOR (array)->contents[idx]; } -INLINE ptrdiff_t -gc_asize (Lisp_Object array) -{ - /* Like ASIZE, but also can be used in the garbage collector. */ - return XVECTOR (array)->header.size & ~ARRAY_MARK_FLAG; -} - INLINE void ASET (Lisp_Object array, ptrdiff_t idx, Lisp_Object val) { @@ -1914,18 +1919,12 @@ memclear (void *p, ptrdiff_t nbytes) (offsetof (type, lastlispfield) + word_size < header_size \ ? 0 : (offsetof (type, lastlispfield) + word_size - header_size) / word_size) -/* Compute A OP B, using the unsigned comparison operator OP. A and B - should be integer expressions. This is not the same as - mathematical comparison; for example, UNSIGNED_CMP (0, <, -1) - returns true. For efficiency, prefer plain unsigned comparison if A - and B's sizes both fit (after integer promotion). */ -#define UNSIGNED_CMP(a, op, b) \ - (max (sizeof ((a) + 0), sizeof ((b) + 0)) <= sizeof (unsigned) \ - ? ((a) + (unsigned) 0) op ((b) + (unsigned) 0) \ - : ((a) + (uintmax_t) 0) op ((b) + (uintmax_t) 0)) - /* True iff C is an ASCII character. */ -#define ASCII_CHAR_P(c) UNSIGNED_CMP (c, <, 0x80) +INLINE bool +ASCII_CHAR_P (intmax_t c) +{ + return 0 <= c && c < 0x80; +} /* A char-table is a kind of vectorlike, with contents are like a vector but with a few other slots. For some purposes, it makes @@ -2798,8 +2797,10 @@ struct Lisp_Float { double data; struct Lisp_Float *chain; + GCALIGNED_UNION_MEMBER } u; - } GCALIGNED_STRUCT; + }; +verify (GCALIGNED (struct Lisp_Float)); INLINE bool (FLOATP) (Lisp_Object x) @@ -2997,28 +2998,6 @@ CHECK_FIXNAT (Lisp_Object x) CHECK_TYPE (FIXNATP (x), Qwholenump, x); } -#define CHECK_RANGED_INTEGER(x, lo, hi) \ - do { \ - CHECK_FIXNUM (x); \ - if (! ((lo) <= XFIXNUM (x) && XFIXNUM (x) <= (hi))) \ - args_out_of_range_3 (x, INT_TO_INTEGER (lo), INT_TO_INTEGER (hi)); \ - } while (false) -#define CHECK_TYPE_RANGED_INTEGER(type, x) \ - do { \ - if (TYPE_SIGNED (type)) \ - CHECK_RANGED_INTEGER (x, TYPE_MINIMUM (type), TYPE_MAXIMUM (type)); \ - else \ - CHECK_RANGED_INTEGER (x, 0, TYPE_MAXIMUM (type)); \ - } while (false) - -#define CHECK_FIXNUM_COERCE_MARKER(x) \ - do { \ - if (MARKERP ((x))) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (FIXNUMP (x), Qinteger_or_marker_p, x); \ - } while (false) - INLINE double XFLOATINT (Lisp_Object n) { @@ -3038,22 +3017,6 @@ CHECK_INTEGER (Lisp_Object x) { CHECK_TYPE (INTEGERP (x), Qnumberp, x); } - -#define CHECK_NUMBER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (NUMBERP (x), Qnumber_or_marker_p, x); \ - } while (false) - -#define CHECK_INTEGER_COERCE_MARKER(x) \ - do { \ - if (MARKERP (x)) \ - XSETFASTINT (x, marker_position (x)); \ - else \ - CHECK_TYPE (INTEGERP (x), Qnumber_or_marker_p, x); \ - } while (false) /* If we're not dumping using the legacy dumper and we might be using @@ -3385,6 +3348,27 @@ struct frame; #define HAVE_EXT_TOOL_BAR true #endif +/* Return the address of vector A's element at index I. */ + +INLINE Lisp_Object * +xvector_contents_addr (Lisp_Object a, ptrdiff_t i) +{ + /* This should return &XVECTOR (a)->contents[i], but that would run + afoul of GCC bug 95072. */ + void *v = XVECTOR (a); + char *p = v; + void *w = p + header_size + i * word_size; + return w; +} + +/* Return the address of vector A's elements. */ + +INLINE Lisp_Object * +xvector_contents (Lisp_Object a) +{ + return xvector_contents_addr (a, 0); +} + /* Copy COUNT Lisp_Objects from ARGS to contents of V starting from OFFSET. */ INLINE void @@ -3392,7 +3376,7 @@ vcopy (Lisp_Object v, ptrdiff_t offset, Lisp_Object const *args, ptrdiff_t count) { eassert (0 <= offset && 0 <= count && offset + count <= ASIZE (v)); - memcpy (XVECTOR (v)->contents + offset, args, count * sizeof *args); + memcpy (xvector_contents_addr (v, offset), args, count * sizeof *args); } /* Functions to modify hash tables. */ @@ -3507,9 +3491,9 @@ set_sub_char_table_contents (Lisp_Object table, ptrdiff_t idx, Lisp_Object val) /* Defined in bignum.c. This part of bignum.c's API does not require the caller to access bignum internals; see bignum.h for that. */ -extern intmax_t bignum_to_intmax (Lisp_Object); -extern uintmax_t bignum_to_uintmax (Lisp_Object); -extern ptrdiff_t bignum_bufsize (Lisp_Object, int); +extern intmax_t bignum_to_intmax (Lisp_Object) ATTRIBUTE_CONST; +extern uintmax_t bignum_to_uintmax (Lisp_Object) ATTRIBUTE_CONST; +extern ptrdiff_t bignum_bufsize (Lisp_Object, int) ATTRIBUTE_CONST; extern ptrdiff_t bignum_to_c_string (char *, ptrdiff_t, Lisp_Object, int); extern Lisp_Object bignum_to_string (Lisp_Object, int); extern Lisp_Object make_bignum_str (char const *, int); @@ -3600,7 +3584,6 @@ extern uintmax_t cons_to_unsigned (Lisp_Object, uintmax_t); extern struct Lisp_Symbol *indirect_variable (struct Lisp_Symbol *); extern AVOID args_out_of_range (Lisp_Object, Lisp_Object); -extern AVOID args_out_of_range_3 (Lisp_Object, Lisp_Object, Lisp_Object); extern AVOID circular_list (Lisp_Object); extern Lisp_Object do_symval_forwarding (lispfwd); enum Set_Internal_Bind { @@ -3653,7 +3636,7 @@ extern bool sweep_weak_table (struct Lisp_Hash_Table *, bool); extern void hexbuf_digest (char *, void const *, int); extern char *extract_data_from_object (Lisp_Object, ptrdiff_t *, ptrdiff_t *); EMACS_UINT hash_string (char const *, ptrdiff_t); -EMACS_UINT sxhash (Lisp_Object, int); +EMACS_UINT sxhash (Lisp_Object); Lisp_Object hashfn_eql (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_equal (Lisp_Object, struct Lisp_Hash_Table *); Lisp_Object hashfn_user_defined (Lisp_Object, struct Lisp_Hash_Table *); @@ -3813,7 +3796,7 @@ extern void parse_str_as_multibyte (const unsigned char *, ptrdiff_t, /* Defined in alloc.c. */ extern void *my_heap_start (void); extern void check_pure_size (void); -extern void allocate_string_data (struct Lisp_String *, EMACS_INT, EMACS_INT); +unsigned char *resize_string_data (Lisp_Object, ptrdiff_t, int, int); extern void malloc_warning (const char *); extern AVOID memory_full (size_t); extern AVOID buffer_memory_full (ptrdiff_t); @@ -3826,7 +3809,15 @@ extern void alloc_unexec_pre (void); extern void alloc_unexec_post (void); extern void mark_maybe_objects (Lisp_Object const *, ptrdiff_t); extern void mark_stack (char const *, char const *); -extern void flush_stack_call_func (void (*func) (void *arg), void *arg); +extern void flush_stack_call_func1 (void (*func) (void *arg), void *arg); + +INLINE void +flush_stack_call_func (void (*func) (void *arg), void *arg) +{ + __builtin_unwind_init (); + flush_stack_call_func1 (func, arg); +} + extern void garbage_collect (void); extern void maybe_garbage_collect (void); extern const char *pending_malloc_warning; @@ -3941,8 +3932,8 @@ build_string (const char *str) extern Lisp_Object pure_cons (Lisp_Object, Lisp_Object); extern Lisp_Object make_vector (ptrdiff_t, Lisp_Object); -extern void make_byte_code (struct Lisp_Vector *); extern struct Lisp_Vector *allocate_vector (ptrdiff_t); +extern struct Lisp_Vector *allocate_nil_vector (ptrdiff_t); /* Make an uninitialized vector for SIZE objects. NOTE: you must be sure that GC cannot happen until the vector is completely @@ -3978,9 +3969,7 @@ make_uninit_sub_char_table (int depth, int min_char) INLINE Lisp_Object make_nil_vector (ptrdiff_t size) { - Lisp_Object vec = make_uninit_vector (size); - memclear (XVECTOR (vec)->contents, size * word_size); - return vec; + return make_lisp_ptr (allocate_nil_vector (size), Lisp_Vectorlike); } extern struct Lisp_Vector *allocate_pseudovector (int, int, int, @@ -4246,6 +4235,8 @@ extern Lisp_Object module_function_documentation (struct Lisp_Module_Function const *); extern module_funcptr module_function_address (struct Lisp_Module_Function const *); +extern void *module_function_data (const struct Lisp_Module_Function *); +extern void module_finalize_function (const struct Lisp_Module_Function *); extern void mark_modules (void); extern void init_module_assertions (bool); extern void syms_of_module (void); @@ -4605,6 +4596,8 @@ extern void seed_random (void *, ptrdiff_t); extern void init_random (void); extern void emacs_backtrace (int); extern AVOID emacs_abort (void) NO_INLINE; +extern int emacs_fstatat (int, char const *, void *, int); +extern int emacs_openat (int, char const *, int, int); extern int emacs_open (const char *, int, int); extern int emacs_pipe (int[2]); extern int emacs_close (int); diff --git a/src/lread.c b/src/lread.c index f9a8cb3e1a0..8064bf4d0eb 100644 --- a/src/lread.c +++ b/src/lread.c @@ -152,12 +152,6 @@ static ptrdiff_t prev_saved_doc_string_length; /* This is the file position that string came from. */ static file_offset prev_saved_doc_string_position; -/* True means inside a new-style backquote with no surrounding - parentheses. Fread initializes this to the value of - `force_new_style_backquotes', so we need not specbind it or worry - about what happens to it when there is an error. */ -static bool new_backquote_flag; - /* A list of file names for files being loaded in Fload. Used to check for recursive loads. */ @@ -231,8 +225,9 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { /* Fetch the character code from the buffer. */ unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, pt_byte); - BUF_INC_POS (inbuffer, pt_byte); - c = STRING_CHAR (p); + int clen; + c = string_char_and_length (p, &clen); + pt_byte += clen; if (multibyte) *multibyte = 1; } @@ -260,8 +255,9 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { /* Fetch the character code from the buffer. */ unsigned char *p = BUF_BYTE_ADDRESS (inbuffer, bytepos); - BUF_INC_POS (inbuffer, bytepos); - c = STRING_CHAR (p); + int clen; + c = string_char_and_length (p, &clen); + bytepos += clen; if (multibyte) *multibyte = 1; } @@ -300,9 +296,10 @@ readchar (Lisp_Object readcharfun, bool *multibyte) { if (multibyte) *multibyte = 1; - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, readcharfun, - read_from_string_index, - read_from_string_index_byte); + c = (fetch_string_char_advance_no_check + (readcharfun, + &read_from_string_index, + &read_from_string_index_byte)); } else { @@ -433,7 +430,7 @@ unreadchar (Lisp_Object readcharfun, int c) ptrdiff_t bytepos = BUF_PT_BYTE (b); if (! NILP (BVAR (b, enable_multibyte_characters))) - BUF_DEC_POS (b, bytepos); + bytepos -= buf_prev_char_len (b, bytepos); else bytepos--; @@ -446,7 +443,7 @@ unreadchar (Lisp_Object readcharfun, int c) XMARKER (readcharfun)->charpos--; if (! NILP (BVAR (b, enable_multibyte_characters))) - BUF_DEC_POS (b, bytepos); + bytepos -= buf_prev_char_len (b, bytepos); else bytepos--; @@ -532,13 +529,11 @@ readbyte_from_string (int c, Lisp_Object readcharfun) = string_char_to_byte (string, read_from_string_index); } - if (read_from_string_index >= read_from_string_limit) - c = -1; - else - FETCH_STRING_CHAR_ADVANCE (c, string, - read_from_string_index, - read_from_string_index_byte); - return c; + return (read_from_string_index < read_from_string_limit + ? fetch_string_char_advance (string, + &read_from_string_index, + &read_from_string_index_byte) + : -1); } @@ -985,9 +980,7 @@ lisp_file_lexically_bound_p (Lisp_Object readcharfun) /* Value is a version number of byte compiled code if the file associated with file descriptor FD is a compiled Lisp file that's - safe to load. Only files compiled with Emacs are safe to load. - Files compiled with XEmacs can lead to a crash in Fbyte_code - because of an incompatible change in the byte compiler. */ + safe to load. Only files compiled with Emacs can be loaded. */ static int safe_to_load_version (int fd) @@ -1035,22 +1028,16 @@ load_error_handler (Lisp_Object data) return Qnil; } -static AVOID -load_error_old_style_backquotes (void) -{ - if (NILP (Vload_file_name)) - xsignal1 (Qerror, build_string ("Old-style backquotes detected!")); - else - { - AUTO_STRING (format, "Loading `%s': old-style backquotes detected!"); - xsignal1 (Qerror, CALLN (Fformat_message, format, Vload_file_name)); - } -} - static void load_warn_unescaped_character_literals (Lisp_Object file) { - Lisp_Object warning = call0 (Qbyte_run_unescaped_character_literals_warning); + Lisp_Object function + = Fsymbol_function (Qbyte_run_unescaped_character_literals_warning); + /* If byte-run.el is being loaded, + `byte-run--unescaped-character-literals-warning' isn't yet + defined. Since it'll be byte-compiled later, ignore potential + unescaped character literals. */ + Lisp_Object warning = NILP (function) ? Qnil : call0 (function); if (!NILP (warning)) { AUTO_STRING (format, "Loading `%s': %s"); @@ -1153,7 +1140,6 @@ Return t if the file exists and loads successfully. */) /* True means we are loading a compiled file. */ bool compiled = 0; Lisp_Object handler; - bool safe_p = 1; const char *fmode = "r" FOPEN_TEXT; int version; @@ -1199,6 +1185,9 @@ Return t if the file exists and loads successfully. */) || suffix_p (file, ".elc") #ifdef HAVE_MODULES || suffix_p (file, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (file, MODULES_SECONDARY_SUFFIX) +#endif #endif ) must_suffix = Qnil; @@ -1268,7 +1257,12 @@ Return t if the file exists and loads successfully. */) } #ifdef HAVE_MODULES - bool is_module = suffix_p (found, MODULES_SUFFIX); + bool is_module = + suffix_p (found, MODULES_SUFFIX) +#ifdef MODULES_SECONDARY_SUFFIX + || suffix_p (found, MODULES_SECONDARY_SUFFIX) +#endif + ; #else bool is_module = false; #endif @@ -1328,11 +1322,7 @@ Return t if the file exists and loads successfully. */) if (version < 0 && ! (version = safe_to_load_version (fd))) { - safe_p = 0; - if (!load_dangerous_libraries) - error ("File `%s' was not compiled in Emacs", SDATA (found)); - else if (!NILP (nomessage) && !force_load_messages) - message_with_string ("File `%s' not compiled in Emacs", found, 1); + error ("File `%s' was not compiled in Emacs", SDATA (found)); } compiled = 1; @@ -1345,11 +1335,11 @@ Return t if the file exists and loads successfully. */) ignores suffix order due to load_prefer_newer. */ if (!load_prefer_newer && is_elc) { - result = stat (SSDATA (efound), &s1); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s1, 0); if (result == 0) { SSET (efound, SBYTES (efound) - 1, 0); - result = stat (SSDATA (efound), &s2); + result = emacs_fstatat (AT_FDCWD, SSDATA (efound), &s2, 0); SSET (efound, SBYTES (efound) - 1, 'c'); } @@ -1439,10 +1429,7 @@ Return t if the file exists and loads successfully. */) if (NILP (nomessage) || force_load_messages) { - if (!safe_p) - message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...", - file, 1); - else if (is_module) + if (is_module) message_with_string ("Loading %s (module)...", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...", file, 1); @@ -1502,10 +1489,7 @@ Return t if the file exists and loads successfully. */) if (!noninteractive && (NILP (nomessage) || force_load_messages)) { - if (!safe_p) - message_with_string ("Loading %s (compiled; note unsafe, not compiled in Emacs)...done", - file, 1); - else if (is_module) + if (is_module) message_with_string ("Loading %s (module)...done", file, 1); else if (!compiled) message_with_string ("Loading %s (source)...done", file, 1); @@ -2275,7 +2259,6 @@ read_internal_start (Lisp_Object stream, Lisp_Object start, Lisp_Object end) Lisp_Object retval; readchar_count = 0; - new_backquote_flag = force_new_style_backquotes; /* We can get called from readevalloop which may have set these already. */ if (! HASH_TABLE_P (read_objects_map) @@ -2983,9 +2966,46 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) struct Lisp_Vector *vec; tmp = read_vector (readcharfun, 1); vec = XVECTOR (tmp); - if (vec->header.size == 0) - invalid_syntax ("Empty byte-code object"); - make_byte_code (vec); + if (! (COMPILED_STACK_DEPTH < ASIZE (tmp) + && (FIXNUMP (AREF (tmp, COMPILED_ARGLIST)) + || CONSP (AREF (tmp, COMPILED_ARGLIST)) + || NILP (AREF (tmp, COMPILED_ARGLIST))) + && ((STRINGP (AREF (tmp, COMPILED_BYTECODE)) + && VECTORP (AREF (tmp, COMPILED_CONSTANTS))) + || CONSP (AREF (tmp, COMPILED_BYTECODE))) + && FIXNATP (AREF (tmp, COMPILED_STACK_DEPTH)))) + invalid_syntax ("Invalid byte-code object"); + + if (STRINGP (AREF (tmp, COMPILED_BYTECODE)) + && STRING_MULTIBYTE (AREF (tmp, COMPILED_BYTECODE))) + { + /* BYTESTR must have been produced by Emacs 20.2 or earlier + because it produced a raw 8-bit string for byte-code and + now such a byte-code string is loaded as multibyte with + raw 8-bit characters converted to multibyte form. + Convert them back to the original unibyte form. */ + ASET (tmp, COMPILED_BYTECODE, + Fstring_as_unibyte (AREF (tmp, COMPILED_BYTECODE))); + } + + if (COMPILED_DOC_STRING < ASIZE (tmp) + && EQ (AREF (tmp, COMPILED_DOC_STRING), make_fixnum (0))) + { + /* read_list found a docstring like '(#$ . 5521)' and treated it + as 0. This placeholder 0 would lead to accidental sharing in + purecopy's hash-consing, so replace it with a (hopefully) + unique integer placeholder, which is negative so that it is + not confused with a DOC file offset (the USE_LSB_TAG shift + relies on the fact that VALMASK is one bit narrower than + INTMASK). Eventually Snarf-documentation should replace the + placeholder with the actual docstring. */ + verify (INTMASK & ~VALMASK); + EMACS_UINT hash = ((XHASH (tmp) >> USE_LSB_TAG) + | (INTMASK - INTMASK / 2)); + ASET (tmp, COMPILED_DOC_STRING, make_ufixnum (hash)); + } + + XSETPVECTYPE (vec, PVEC_COMPILED); return tmp; } if (c == '(') @@ -3263,70 +3283,24 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) return list2 (Qquote, read0 (readcharfun)); case '`': - { - int next_char = READCHAR; - UNREAD (next_char); - /* Transition from old-style to new-style: - If we see "(`" it used to mean old-style, which usually works - fine because ` should almost never appear in such a position - for new-style. But occasionally we need "(`" to mean new - style, so we try to distinguish the two by the fact that we - can either write "( `foo" or "(` foo", where the first - intends to use new-style whereas the second intends to use - old-style. For Emacs-25, we should completely remove this - first_in_list exception (old-style can still be obtained via - "(\`" anyway). */ - if (!new_backquote_flag && first_in_list && next_char == ' ') - load_error_old_style_backquotes (); - else - { - Lisp_Object value; - bool saved_new_backquote_flag = new_backquote_flag; + return list2 (Qbackquote, read0 (readcharfun)); - new_backquote_flag = 1; - value = read0 (readcharfun); - new_backquote_flag = saved_new_backquote_flag; - - return list2 (Qbackquote, value); - } - } case ',': { - int next_char = READCHAR; - UNREAD (next_char); - /* Transition from old-style to new-style: - It used to be impossible to have a new-style , other than within - a new-style `. This is sufficient when ` and , are used in the - normal way, but ` and , can also appear in args to macros that - will not interpret them in the usual way, in which case , may be - used without any ` anywhere near. - So we now use the same heuristic as for backquote: old-style - unquotes are only recognized when first on a list, and when - followed by a space. - Because it's more difficult to peek 2 chars ahead, a new-style - ,@ can still not be used outside of a `, unless it's in the middle - of a list. */ - if (new_backquote_flag - || !first_in_list - || (next_char != ' ' && next_char != '@')) - { - Lisp_Object comma_type = Qnil; - Lisp_Object value; - int ch = READCHAR; - - if (ch == '@') - comma_type = Qcomma_at; - else - { - if (ch >= 0) UNREAD (ch); - comma_type = Qcomma; - } + Lisp_Object comma_type = Qnil; + Lisp_Object value; + int ch = READCHAR; - value = read0 (readcharfun); - return list2 (comma_type, value); - } + if (ch == '@') + comma_type = Qcomma_at; else - load_error_old_style_backquotes (); + { + if (ch >= 0) UNREAD (ch); + comma_type = Qcomma; + } + + value = read0 (readcharfun); + return list2 (comma_type, value); } case '?': { @@ -3869,10 +3843,12 @@ read_vector (Lisp_Object readcharfun, bool bytecodeflag) { Lisp_Object tem = read_list (1, readcharfun); ptrdiff_t size = list_length (tem); - if (bytecodeflag && size <= COMPILED_STACK_DEPTH) - error ("Invalid byte code"); Lisp_Object vector = make_nil_vector (size); + /* Avoid accessing past the end of a vector if the vector is too + small to be valid for bytecode. */ + bytecodeflag &= COMPILED_STACK_DEPTH < size; + Lisp_Object *ptr = XVECTOR (vector)->contents; for (ptrdiff_t i = 0; i < size; i++) { @@ -4856,9 +4832,16 @@ This list should not include the empty string. `load' and related functions try to append these suffixes, in order, to the specified file name if a suffix is allowed or required. */); #ifdef HAVE_MODULES +#ifdef MODULES_SECONDARY_SUFFIX + Vload_suffixes = list4 (build_pure_c_string (".elc"), + build_pure_c_string (".el"), + build_pure_c_string (MODULES_SUFFIX), + build_pure_c_string (MODULES_SECONDARY_SUFFIX)); +#else Vload_suffixes = list3 (build_pure_c_string (".elc"), build_pure_c_string (".el"), build_pure_c_string (MODULES_SUFFIX)); +#endif #else Vload_suffixes = list2 (build_pure_c_string (".elc"), build_pure_c_string (".el")); @@ -5007,7 +4990,7 @@ This overrides the value of the NOMESSAGE argument to `load'. */); When Emacs loads a compiled Lisp file, it reads the first 512 bytes from the file, and matches them against this regular expression. When the regular expression matches, the file is considered to be safe -to load. See also `load-dangerous-libraries'. */); +to load. */); Vbytecomp_version_regexp = build_pure_c_string ("^;;;.\\(in Emacs version\\|bytecomp version FSF\\)"); @@ -5050,17 +5033,6 @@ Note that if you customize this, obviously it will not affect files that are loaded before your customizations are read! */); load_prefer_newer = 0; - DEFVAR_BOOL ("force-new-style-backquotes", force_new_style_backquotes, - doc: /* Non-nil means to always use the current syntax for backquotes. -If nil, `load' and `read' raise errors when encountering some -old-style variants of backquote and comma. If non-nil, these -constructs are always interpreted as described in the Info node -`(elisp)Backquote', even if that interpretation is incompatible with -previous versions of Emacs. Setting this variable to non-nil makes -Emacs compatible with the behavior planned for Emacs 28. In Emacs 28, -this variable will become obsolete. */); - force_new_style_backquotes = false; - /* Vsource_directory was initialized in init_lread. */ DEFSYM (Qcurrent_load_list, "current-load-list"); diff --git a/src/macfont.m b/src/macfont.m index c589b6685eb..21bc7dde5b3 100644 --- a/src/macfont.m +++ b/src/macfont.m @@ -1126,7 +1126,8 @@ struct macfont_metrics }; #define METRICS_VALUE(metrics, member) \ - (((metrics)->member##_high << 8) | (metrics)->member##_low) + ((int) (((unsigned int) (metrics)->member##_high << 8) \ + | (metrics)->member##_low)) #define METRICS_SET_VALUE(metrics, member, value) \ do {short tmp = (value); (metrics)->member##_low = tmp & 0xff; \ (metrics)->member##_high = tmp >> 8;} while (0) diff --git a/src/marker.c b/src/marker.c index 684b7509c51..64f210db88b 100644 --- a/src/marker.c +++ b/src/marker.c @@ -221,7 +221,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) while (best_below != charpos) { best_below++; - BUF_INC_POS (b, best_below_byte); + best_below_byte += buf_next_char_len (b, best_below_byte); } /* If this position is quite far from the nearest known position, @@ -246,7 +246,7 @@ buf_charpos_to_bytepos (struct buffer *b, ptrdiff_t charpos) while (best_above != charpos) { best_above--; - BUF_DEC_POS (b, best_above_byte); + best_above_byte -= buf_prev_char_len (b, best_above_byte); } /* If this position is quite far from the nearest known position, @@ -372,7 +372,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) while (best_below_byte < bytepos) { best_below++; - BUF_INC_POS (b, best_below_byte); + best_below_byte += buf_next_char_len (b, best_below_byte); } /* If this position is quite far from the nearest known position, @@ -399,7 +399,7 @@ buf_bytepos_to_charpos (struct buffer *b, ptrdiff_t bytepos) while (best_above_byte > bytepos) { best_above--; - BUF_DEC_POS (b, best_above_byte); + best_above_byte -= buf_prev_char_len (b, best_above_byte); } /* If this position is quite far from the nearest known position, @@ -804,7 +804,7 @@ verify_bytepos (ptrdiff_t charpos) while (below != charpos) { below++; - BUF_INC_POS (current_buffer, below_byte); + below_byte += buf_next_char_len (current_buffer, below_byte); } return below_byte; diff --git a/src/menu.c b/src/menu.c index 28bfcae05d6..e4fda572cd8 100644 --- a/src/menu.c +++ b/src/menu.c @@ -1036,9 +1036,7 @@ menu_item_width (const unsigned char *str) for (len = 0, p = str; *p; ) { - int ch_len; - int ch = STRING_CHAR_AND_LENGTH (p, ch_len); - + int ch_len, ch = string_char_and_length (p, &ch_len); len += CHARACTER_WIDTH (ch); p += ch_len; } @@ -1253,18 +1251,16 @@ x_popup_menu_1 (Lisp_Object position, Lisp_Object menu) but I don't want to make one now. */ CHECK_WINDOW (window); - CHECK_RANGED_INTEGER (x, - (xpos < INT_MIN - MOST_NEGATIVE_FIXNUM - ? (EMACS_INT) INT_MIN - xpos - : MOST_NEGATIVE_FIXNUM), - INT_MAX - xpos); - CHECK_RANGED_INTEGER (y, - (ypos < INT_MIN - MOST_NEGATIVE_FIXNUM - ? (EMACS_INT) INT_MIN - ypos - : MOST_NEGATIVE_FIXNUM), - INT_MAX - ypos); - xpos += XFIXNUM (x); - ypos += XFIXNUM (y); + xpos += check_integer_range (x, + (xpos < INT_MIN - MOST_NEGATIVE_FIXNUM + ? (EMACS_INT) INT_MIN - xpos + : MOST_NEGATIVE_FIXNUM), + INT_MAX - xpos); + ypos += check_integer_range (y, + (ypos < INT_MIN - MOST_NEGATIVE_FIXNUM + ? (EMACS_INT) INT_MIN - ypos + : MOST_NEGATIVE_FIXNUM), + INT_MAX - ypos); XSETFRAME (Vmenu_updating_frame, f); } diff --git a/src/mini-gmp-emacs.c b/src/mini-gmp-emacs.c deleted file mode 100644 index b8399b075e0..00000000000 --- a/src/mini-gmp-emacs.c +++ /dev/null @@ -1,32 +0,0 @@ -/* Tailor mini-gmp.c for GNU Emacs - -Copyright 2018-2020 Free Software Foundation, Inc. - -This file is part of GNU Emacs. - -GNU Emacs is free software: you can redistribute it and/or modify -it under the terms of the GNU General Public License as published by -the Free Software Foundation, either version 3 of the License, or (at -your option) any later version. - -GNU Emacs is distributed in the hope that it will be useful, -but WITHOUT ANY WARRANTY; without even the implied warranty of -MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -GNU General Public License for more details. - -You should have received a copy of the GNU General Public License -along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ - -#include <config.h> - -#include <stddef.h> - -/* Pacify GCC -Wsuggest-attribute=malloc. */ -static void *gmp_default_alloc (size_t) ATTRIBUTE_MALLOC; - -/* Pacify GCC -Wunused-variable for variables used only in 'assert' calls. */ -#if defined NDEBUG && GNUC_PREREQ (4, 6, 0) -# pragma GCC diagnostic ignored "-Wunused-variable" -#endif - -#include "mini-gmp.c" diff --git a/src/minibuf.c b/src/minibuf.c index b837cc53eb9..9d870ce3640 100644 --- a/src/minibuf.c +++ b/src/minibuf.c @@ -414,12 +414,13 @@ read_minibuf (Lisp_Object map, Lisp_Object initial, Lisp_Object prompt, if (!enable_recursive_minibuffers && minibuf_level > 0) { + Lisp_Object str + = build_string ("Command attempted to use minibuffer while in minibuffer"); if (EQ (selected_window, minibuf_window)) - error ("Command attempted to use minibuffer while in minibuffer"); + Fsignal (Quser_error, (list1 (str))); else /* If we're in another window, cancel the minibuffer that's active. */ - Fthrow (Qexit, - build_string ("Command attempted to use minibuffer while in minibuffer")); + Fthrow (Qexit, str); } if ((noninteractive diff --git a/src/module-env-25.h b/src/module-env-25.h index d8f8eb68119..01ce65e9148 100644 --- a/src/module-env-25.h +++ b/src/module-env-25.h @@ -6,12 +6,10 @@ /* Memory management. */ - emacs_value (*make_global_ref) (emacs_env *env, - emacs_value any_reference) + emacs_value (*make_global_ref) (emacs_env *env, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - void (*free_global_ref) (emacs_env *env, - emacs_value global_reference) + void (*free_global_ref) (emacs_env *env, emacs_value global_value) EMACS_ATTRIBUTE_NONNULL(1); /* Non-local exit handling. */ @@ -23,19 +21,15 @@ EMACS_ATTRIBUTE_NONNULL(1); enum emacs_funcall_exit (*non_local_exit_get) - (emacs_env *env, - emacs_value *non_local_exit_symbol_out, - emacs_value *non_local_exit_data_out) + (emacs_env *env, emacs_value *symbol, emacs_value *data) EMACS_ATTRIBUTE_NONNULL(1, 2, 3); void (*non_local_exit_signal) (emacs_env *env, - emacs_value non_local_exit_symbol, - emacs_value non_local_exit_data) + emacs_value symbol, emacs_value data) EMACS_ATTRIBUTE_NONNULL(1); void (*non_local_exit_throw) (emacs_env *env, - emacs_value tag, - emacs_value value) + emacs_value tag, emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); /* Function registration. */ @@ -43,48 +37,46 @@ emacs_value (*make_function) (emacs_env *env, ptrdiff_t min_arity, ptrdiff_t max_arity, - emacs_value (*function) (emacs_env *env, - ptrdiff_t nargs, - emacs_value args[], - void *) + emacs_value (*func) (emacs_env *env, + ptrdiff_t nargs, + emacs_value* args, + void *data) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1), - const char *documentation, + const char *docstring, void *data) EMACS_ATTRIBUTE_NONNULL(1, 4); emacs_value (*funcall) (emacs_env *env, - emacs_value function, + emacs_value func, ptrdiff_t nargs, - emacs_value args[]) + emacs_value* args) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*intern) (emacs_env *env, - const char *symbol_name) + emacs_value (*intern) (emacs_env *env, const char *name) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Type conversion. */ - emacs_value (*type_of) (emacs_env *env, - emacs_value value) + emacs_value (*type_of) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - bool (*is_not_nil) (emacs_env *env, emacs_value value) + bool (*is_not_nil) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); bool (*eq) (emacs_env *env, emacs_value a, emacs_value b) EMACS_ATTRIBUTE_NONNULL(1); - intmax_t (*extract_integer) (emacs_env *env, emacs_value value) + intmax_t (*extract_integer) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_integer) (emacs_env *env, intmax_t value) + emacs_value (*make_integer) (emacs_env *env, intmax_t n) EMACS_ATTRIBUTE_NONNULL(1); - double (*extract_float) (emacs_env *env, emacs_value value) + double (*extract_float) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - emacs_value (*make_float) (emacs_env *env, double value) + emacs_value (*make_float) (emacs_env *env, double d) EMACS_ATTRIBUTE_NONNULL(1); /* Copy the content of the Lisp string VALUE to BUFFER as an utf8 @@ -101,13 +93,13 @@ bool (*copy_string_contents) (emacs_env *env, emacs_value value, - char *buffer, - ptrdiff_t *size_inout) + char *buf, + ptrdiff_t *len) EMACS_ATTRIBUTE_NONNULL(1, 4); /* Create a Lisp string from a utf8 encoded string. */ emacs_value (*make_string) (emacs_env *env, - const char *contents, ptrdiff_t length) + const char *str, ptrdiff_t len) EMACS_ATTRIBUTE_NONNULL(1, 2); /* Embedded pointer type. */ @@ -116,25 +108,24 @@ void *ptr) EMACS_ATTRIBUTE_NONNULL(1); - void *(*get_user_ptr) (emacs_env *env, emacs_value uptr) + void *(*get_user_ptr) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_ptr) (emacs_env *env, emacs_value uptr, void *ptr) + void (*set_user_ptr) (emacs_env *env, emacs_value arg, void *ptr) EMACS_ATTRIBUTE_NONNULL(1); void (*(*get_user_finalizer) (emacs_env *env, emacs_value uptr)) (void *) EMACS_NOEXCEPT EMACS_ATTRIBUTE_NONNULL(1); - void (*set_user_finalizer) (emacs_env *env, - emacs_value uptr, + void (*set_user_finalizer) (emacs_env *env, emacs_value arg, void (*fin) (void *) EMACS_NOEXCEPT) EMACS_ATTRIBUTE_NONNULL(1); /* Vector functions. */ - emacs_value (*vec_get) (emacs_env *env, emacs_value vec, ptrdiff_t i) + emacs_value (*vec_get) (emacs_env *env, emacs_value vector, ptrdiff_t index) EMACS_ATTRIBUTE_NONNULL(1); - void (*vec_set) (emacs_env *env, emacs_value vec, ptrdiff_t i, - emacs_value val) + void (*vec_set) (emacs_env *env, emacs_value vector, ptrdiff_t index, + emacs_value value) EMACS_ATTRIBUTE_NONNULL(1); - ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vec) + ptrdiff_t (*vec_size) (emacs_env *env, emacs_value vector) EMACS_ATTRIBUTE_NONNULL(1); diff --git a/src/module-env-27.h b/src/module-env-27.h index 0fe2557d71b..9ef3c8b33bb 100644 --- a/src/module-env-27.h +++ b/src/module-env-27.h @@ -3,7 +3,7 @@ enum emacs_process_input_result (*process_input) (emacs_env *env) EMACS_ATTRIBUTE_NONNULL (1); - struct timespec (*extract_time) (emacs_env *env, emacs_value value) + struct timespec (*extract_time) (emacs_env *env, emacs_value arg) EMACS_ATTRIBUTE_NONNULL (1); emacs_value (*make_time) (emacs_env *env, struct timespec time) diff --git a/src/module-env-28.h b/src/module-env-28.h new file mode 100644 index 00000000000..5d884c148c4 --- /dev/null +++ b/src/module-env-28.h @@ -0,0 +1,14 @@ + /* Add module environment functions newly added in Emacs 28 here. + Before Emacs 28 is released, remove this comment and start + module-env-29.h on the master branch. */ + + void (*(*EMACS_ATTRIBUTE_NONNULL (1) + get_function_finalizer) (emacs_env *env, + emacs_value arg)) (void *) EMACS_NOEXCEPT; + + void (*set_function_finalizer) (emacs_env *env, emacs_value arg, + void (*fin) (void *) EMACS_NOEXCEPT) + EMACS_ATTRIBUTE_NONNULL (1); + + int (*open_channel) (emacs_env *env, emacs_value pipe_process) + EMACS_ATTRIBUTE_NONNULL (1); diff --git a/src/msdos.c b/src/msdos.c index 6a89178a6e9..b5f06c99c3d 100644 --- a/src/msdos.c +++ b/src/msdos.c @@ -1794,7 +1794,7 @@ internal_terminal_init (void) } Vinitial_window_system = Qpc; - Vwindow_system_version = make_fixnum (27); /* RE Emacs version */ + Vwindow_system_version = make_fixnum (28); /* RE Emacs version */ tty->terminal->type = output_msdos_raw; /* If Emacs was dumped on DOS/V machine, forget the stale VRAM @@ -2905,7 +2905,7 @@ IT_menu_display (XMenu *menu, int y, int x, int pn, int *faces, int disp_help) p++; for (j = 0, q = menu->text[i]; *q; j++) { - unsigned c = STRING_CHAR_ADVANCE (q); + unsigned c = string_char_advance (&q); if (c > 26) { diff --git a/src/nsfns.m b/src/nsfns.m index 0f879fe390c..628233ea0dd 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -255,7 +255,10 @@ ns_set_foreground_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_FOREGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (FRAME_NS_VIEW (f)) { @@ -284,19 +287,16 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) error ("Unknown color"); } - /* Clear the frame; in some instances the NS-internal GC appears not - to update, or it does update and cannot clear old text - properly. */ - if (FRAME_VISIBLE_P (f)) - ns_clear_frame (f); - [col retain]; [f->output_data.ns->background_color release]; f->output_data.ns->background_color = col; [col getRed: &r green: &g blue: &b alpha: &alpha]; FRAME_BACKGROUND_PIXEL (f) = - ARGB_TO_ULONG ((int)(alpha*0xff), (int)(r*0xff), (int)(g*0xff), (int)(b*0xff)); + ARGB_TO_ULONG ((unsigned long) (alpha * 0xff), + (unsigned long) (r * 0xff), + (unsigned long) (g * 0xff), + (unsigned long) (b * 0xff)); if (view != nil) { @@ -318,7 +318,10 @@ ns_set_background_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) } if (FRAME_VISIBLE_P (f)) - SET_FRAME_GARBAGED (f); + { + SET_FRAME_GARBAGED (f); + ns_clear_frame (f); + } } unblock_input (); } @@ -703,14 +706,11 @@ static void ns_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { int old_width = FRAME_INTERNAL_BORDER_WIDTH (f); + int new_width = check_int_nonnegative (arg); - CHECK_TYPE_RANGED_INTEGER (int, arg); - f->internal_border_width = XFIXNUM (arg); - if (FRAME_INTERNAL_BORDER_WIDTH (f) < 0) - f->internal_border_width = 0; - - if (FRAME_INTERNAL_BORDER_WIDTH (f) == old_width) + if (new_width == old_width) return; + f->internal_border_width = new_width; if (FRAME_NATIVE_WINDOW (f) != 0) adjust_frame_size (f, -1, -1, 3, 0, Qinternal_border_width); @@ -1271,14 +1271,20 @@ DEFUN ("x-create-frame", Fx_create_frame, Sx_create_frame, #ifdef NS_IMPL_COCOA tem = gui_display_get_arg (dpyinfo, parms, Qns_appearance, NULL, NULL, RES_TYPE_SYMBOL); - FRAME_NS_APPEARANCE (f) = EQ (tem, Qdark) - ? ns_appearance_vibrant_dark : ns_appearance_aqua; - store_frame_param (f, Qns_appearance, tem); + if (EQ (tem, Qdark)) + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (tem, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; + else + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + store_frame_param (f, Qns_appearance, + (!NILP (tem) && !EQ (tem, Qunbound)) ? tem : Qnil); tem = gui_display_get_arg (dpyinfo, parms, Qns_transparent_titlebar, NULL, NULL, RES_TYPE_BOOLEAN); FRAME_NS_TRANSPARENT_TITLEBAR (f) = !NILP (tem) && !EQ (tem, Qunbound); - store_frame_param (f, Qns_transparent_titlebar, tem); + store_frame_param (f, Qns_transparent_titlebar, + FRAME_NS_TRANSPARENT_TITLEBAR (f) ? Qt : Qnil); #endif parent_frame = gui_display_get_arg (dpyinfo, parms, Qparent_frame, NULL, NULL, @@ -2323,8 +2329,8 @@ DEFUN ("xw-color-values", Fxw_color_values, Sxw_color_values, 1, 2, 0, [[col colorUsingDefaultColorSpace] getRed: &red green: &green blue: &blue alpha: &alpha]; unblock_input (); - return list3i (lrint (red * 65280), lrint (green * 65280), - lrint (blue * 65280)); + return list3i (lrint (red * 65535), lrint (green * 65535), + lrint (blue * 65535)); } @@ -2947,16 +2953,16 @@ The coordinates X and Y are interpreted in pixels relative to a position if (FRAME_INITIAL_P (f) || !FRAME_NS_P (f)) return Qnil; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); - mouse_x = screen_frame.origin.x + XFIXNUM (x); + mouse_x = screen_frame.origin.x + xval; if (screen == primary_screen) - mouse_y = screen_frame.origin.y + XFIXNUM (y); + mouse_y = screen_frame.origin.y + yval; else mouse_y = (primary_screen_height - screen_frame.size.height - - screen_frame.origin.y) + XFIXNUM (y); + - screen_frame.origin.y) + yval; CGPoint mouse_pos = CGPointMake(mouse_x, mouse_y); CGWarpMouseCursorPosition (mouse_pos); @@ -3003,80 +3009,6 @@ DEFUN ("ns-show-character-palette", ========================================================================== */ -/* - Handle arrow/function/control keys and copy/paste/cut in file dialogs. - Return YES if handled, NO if not. - */ -static BOOL -handlePanelKeys (NSSavePanel *panel, NSEvent *theEvent) -{ - NSString *s; - int i; - BOOL ret = NO; - - if ([theEvent type] != NSEventTypeKeyDown) return NO; - s = [theEvent characters]; - - for (i = 0; i < [s length]; ++i) - { - int ch = (int) [s characterAtIndex: i]; - switch (ch) - { - case NSHomeFunctionKey: - case NSDownArrowFunctionKey: - case NSUpArrowFunctionKey: - case NSLeftArrowFunctionKey: - case NSRightArrowFunctionKey: - case NSPageUpFunctionKey: - case NSPageDownFunctionKey: - case NSEndFunctionKey: - /* Don't send command modified keys, as those are handled in the - performKeyEquivalent method of the super class. */ - if (! ([theEvent modifierFlags] & NSEventModifierFlagCommand)) - { - [panel sendEvent: theEvent]; - ret = YES; - } - break; - /* As we don't have the standard key commands for - copy/paste/cut/select-all in our edit menu, we must handle - them here. TODO: handle Emacs key bindings for copy/cut/select-all - here, paste works, because we have that in our Edit menu. - I.e. refactor out code in nsterm.m, keyDown: to figure out the - correct modifier. */ - case 'x': // Cut - case 'c': // Copy - case 'v': // Paste - case 'a': // Select all - if ([theEvent modifierFlags] & NSEventModifierFlagCommand) - { - [NSApp sendAction: - (ch == 'x' - ? @selector(cut:) - : (ch == 'c' - ? @selector(copy:) - : (ch == 'v' - ? @selector(paste:) - : @selector(selectAll:)))) - to:nil from:panel]; - ret = YES; - } - default: - // Send all control keys, as the text field supports C-a, C-f, C-e - // C-b and more. - if ([theEvent modifierFlags] & NSEventModifierFlagControl) - { - [panel sendEvent: theEvent]; - ret = YES; - } - break; - } - } - - - return ret; -} - @implementation EmacsFileDelegate /* -------------------------------------------------------------------------- Delegate methods for Open/Save panels @@ -3112,6 +3044,7 @@ syms_of_nsfns (void) DEFSYM (Qframe_title_format, "frame-title-format"); DEFSYM (Qicon_title_format, "icon-title-format"); DEFSYM (Qdark, "dark"); + DEFSYM (Qlight, "light"); DEFVAR_LISP ("ns-icon-type-alist", Vns_icon_type_alist, doc: /* Alist of elements (REGEXP . IMAGE) for images of icons associated to frames. diff --git a/src/nsfont.m b/src/nsfont.m index 9bec3691786..691becda6da 100644 --- a/src/nsfont.m +++ b/src/nsfont.m @@ -1043,7 +1043,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, r.origin.x = s->x; if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - r.origin.x += abs (s->face->box_line_width); + r.origin.x += max (s->face->box_vertical_line_width, 0); r.origin.y = s->y; r.size.height = FONT_HEIGHT (font); @@ -1090,7 +1090,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, twidth += cwidth; #ifdef NS_IMPL_GNUSTEP *adv++ = cwidth; - CHAR_STRING_ADVANCE (*t, c); /* This converts the char to UTF-8. */ + c += CHAR_STRING (*t, c); /* This converts the char to UTF-8. */ #else (*adv++).width = cwidth; #endif @@ -1105,7 +1105,7 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, { NSRect br = r; int fibw = FRAME_INTERNAL_BORDER_WIDTH (s->f); - int mbox_line_width = max (s->face->box_line_width, 0); + int mbox_line_width = max (s->face->box_vertical_line_width, 0); if (s->row->full_width_p) { @@ -1129,9 +1129,10 @@ nsfont_draw (struct glyph_string *s, int from, int to, int x, int y, } else { - int correction = abs (s->face->box_line_width)+1; + int correction = abs (s->face->box_horizontal_line_width)+1; br.origin.y += correction; br.size.height -= 2*correction; + correction = abs (s->face->box_vertical_line_width)+1; br.origin.x += correction; br.size.width -= 2*correction; } diff --git a/src/nsimage.m b/src/nsimage.m index fa1e98b8848..07750de95fe 100644 --- a/src/nsimage.m +++ b/src/nsimage.m @@ -45,6 +45,55 @@ GNUstep port and post-20 update by Adrian Robert (arobert@cogsci.ucsd.edu) ========================================================================== */ +bool +ns_can_use_native_image_api (Lisp_Object type) +{ + NSString *imageType = @"unknown"; + NSArray *types; + + NSTRACE ("ns_can_use_native_image_api"); + + if (EQ (type, Qnative_image)) + return YES; + +#ifdef NS_IMPL_COCOA + /* Work out the UTI of the image type. */ + if (EQ (type, Qjpeg)) + imageType = @"public.jpeg"; + else if (EQ (type, Qpng)) + imageType = @"public.png"; + else if (EQ (type, Qgif)) + imageType = @"com.compuserve.gif"; + else if (EQ (type, Qtiff)) + imageType = @"public.tiff"; + else if (EQ (type, Qsvg)) + imageType = @"public.svg-image"; + + /* NSImage also supports a host of other types such as PDF and BMP, + but we don't yet support these in image.c. */ + + types = [NSImage imageTypes]; +#else + /* Work out the image type. */ + if (EQ (type, Qjpeg)) + imageType = @"jpeg"; + else if (EQ (type, Qpng)) + imageType = @"png"; + else if (EQ (type, Qgif)) + imageType = @"gif"; + else if (EQ (type, Qtiff)) + imageType = @"tiff"; + + types = [NSImage imageFileTypes]; +#endif + + /* Check if the type is supported on this system. */ + if ([types indexOfObject:imageType] != NSNotFound) + return YES; + else + return NO; +} + void * ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg) @@ -407,9 +456,10 @@ ns_set_alpha (void *img, int x, int y, unsigned char a) if (pixmapData[0] != NULL) { int loc = x + y * [self size].width; - return (pixmapData[3][loc] << 24) /* alpha */ - | (pixmapData[0][loc] << 16) | (pixmapData[1][loc] << 8) - | (pixmapData[2][loc]); + return (((unsigned long) pixmapData[3][loc] << 24) /* alpha */ + | ((unsigned long) pixmapData[0][loc] << 16) + | ((unsigned long) pixmapData[1][loc] << 8) + | (unsigned long) pixmapData[2][loc]); } else { diff --git a/src/nsmenu.m b/src/nsmenu.m index 67f9a45a401..b7e4cbd5654 100644 --- a/src/nsmenu.m +++ b/src/nsmenu.m @@ -1141,8 +1141,6 @@ update_frame_tool_bar (struct frame *f) } #endif - if (oldh != FRAME_TOOLBAR_HEIGHT (f)) - [view updateFrameSize:YES]; if (view->wait_for_tool_bar && FRAME_TOOLBAR_HEIGHT (f) > 0) { view->wait_for_tool_bar = NO; diff --git a/src/nsterm.h b/src/nsterm.h index f68c3246a70..8d5371c8f24 100644 --- a/src/nsterm.h +++ b/src/nsterm.h @@ -339,6 +339,16 @@ typedef id instancetype; #endif +/* macOS 10.14 and above cannot draw directly "to the glass" and + therefore we draw to an offscreen buffer and swap it in when the + toolkit wants to draw the frame. GNUstep and macOS 10.7 and below + do not support this method, so we revert to drawing directly to the + glass. */ +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101400 +#define NS_DRAW_TO_BUFFER 1 +#endif + + /* ========================================================================== NSColor, EmacsColor category. @@ -417,9 +427,12 @@ typedef id instancetype; int maximized_width, maximized_height; NSWindow *nonfs_window; BOOL fs_is_native; + BOOL in_fullscreen_transition; +#ifdef NS_DRAW_TO_BUFFER + CGContextRef drawingBuffer; +#endif @public struct frame *emacsframe; - int rows, cols; int scrollbarsNeedingUpdate; EmacsToolbar *toolbar; NSRect ns_userRect; @@ -438,16 +451,16 @@ typedef id instancetype; /* Emacs-side interface */ - (instancetype) initFrameFromEmacs: (struct frame *) f; - (void) createToolbar: (struct frame *)f; -- (void) setRows: (int) r andColumns: (int) c; - (void) setWindowClosing: (BOOL)closing; - (EmacsToolbar *) toolbar; - (void) deleteWorkingText; -- (void) updateFrameSize: (BOOL) delay; - (void) handleFS; - (void) setFSValue: (int)value; - (void) toggleFullScreen: (id) sender; - (BOOL) fsIsNative; - (BOOL) isFullscreen; +- (BOOL) inFullScreenTransition; +- (void) waitFullScreenTransition; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 - (void) updateCollectionBehavior; #endif @@ -457,7 +470,13 @@ typedef id instancetype; #endif - (int)fullscreenState; -/* Non-notification versions of NSView methods. Used for direct calls. */ +#ifdef NS_DRAW_TO_BUFFER +- (void)focusOnDrawingBuffer; +- (void)createDrawingBuffer; +#endif +- (void)copyRect:(NSRect)srcRect to:(NSRect)dstRect; + +/* Non-notification versions of NSView methods. Used for direct calls. */ - (void)windowWillEnterFullScreen; - (void)windowDidEnterFullScreen; - (void)windowWillExitFullScreen; @@ -471,6 +490,8 @@ typedef id instancetype; { NSPoint grabOffset; } + +- (void)setAppearance; @end @@ -1054,18 +1075,6 @@ struct x_output (FRAME_SCROLL_BAR_LINES (f) * FRAME_LINE_HEIGHT (f) \ - NS_SCROLL_BAR_HEIGHT (f)) : 0) -/* Calculate system coordinates of the left and top of the parent - window or, if there is no parent window, the screen. */ -#define NS_PARENT_WINDOW_LEFT_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.x : 0) -#define NS_PARENT_WINDOW_TOP_POS(f) \ - (FRAME_PARENT_FRAME (f) != NULL \ - ? ([FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.origin.y \ - + [FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)) window].frame.size.height \ - - FRAME_NS_TITLEBAR_HEIGHT (FRAME_PARENT_FRAME (f))) \ - : [[[NSScreen screens] objectAtIndex: 0] frame].size.height) - #define FRAME_NS_FONT_TABLE(f) (FRAME_DISPLAY_INFO (f)->font_table) #define FRAME_FONTSET(f) ((f)->output_data.ns->fontset) @@ -1180,6 +1189,7 @@ extern void syms_of_nsselect (void); /* From nsimage.m, needed in image.c */ struct image; +extern bool ns_can_use_native_image_api (Lisp_Object type); extern void *ns_image_from_XBM (char *bits, int width, int height, unsigned long fg, unsigned long bg); extern void *ns_image_for_XPM (int width, int height, int depth); @@ -1259,6 +1269,7 @@ extern char gnustep_base_version[]; /* version tracking */ #if !defined (NS_IMPL_COCOA) || !defined (MAC_OS_X_VERSION_10_7) #define NSFullScreenWindowMask (1 << 14) #define NSWindowCollectionBehaviorFullScreenPrimary (1 << 7) +#define NSWindowCollectionBehaviorFullScreenAuxiliary (1 << 8) #define NSApplicationPresentationFullScreen (1 << 10) #define NSApplicationPresentationAutoHideToolbar (1 << 11) #define NSAppKitVersionNumber10_7 1138 diff --git a/src/nsterm.m b/src/nsterm.m index ac467840a25..0e405fc0175 100644 --- a/src/nsterm.m +++ b/src/nsterm.m @@ -287,7 +287,10 @@ struct ns_display_info *x_display_list; /* Chain of existing displays */ long context_menu_value = 0; /* display update */ +static struct frame *ns_updating_frame; +static NSView *focus_view = NULL; static int ns_window_num = 0; +static BOOL gsaved = NO; static BOOL ns_fake_keydown = NO; #ifdef NS_IMPL_COCOA static BOOL ns_menu_bar_is_hidden = NO; @@ -840,6 +843,32 @@ ns_menu_bar_height (NSScreen *screen) } +/* Get the frame rect, in system coordinates, of the parent window or, + if there is no parent window, the main screen. */ +static inline NSRect +ns_parent_window_rect (struct frame *f) +{ + NSRect parentRect; + + if (FRAME_PARENT_FRAME (f) != NULL) + { + EmacsView *parentView = FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)); + parentRect = [parentView convertRect:[parentView frame] + toView:nil]; + parentRect = [[parentView window] convertRectToScreen:parentRect]; + } + else + parentRect = [[[NSScreen screens] objectAtIndex:0] frame]; + + return parentRect; +} + +/* Calculate system coordinates of the left and top of the parent + window or, if there is no parent window, the main screen. */ +#define NS_PARENT_WINDOW_LEFT_POS(f) NSMinX (ns_parent_window_rect (f)) +#define NS_PARENT_WINDOW_TOP_POS(f) NSMaxY (ns_parent_window_rect (f)) + + static NSRect ns_row_rect (struct window *w, struct glyph_row *row, enum glyph_row_area area) @@ -1097,13 +1126,12 @@ ns_update_begin (struct frame *f) external (RIF) call; whole frame, called before gui_update_window_begin -------------------------------------------------------------------------- */ { -#ifdef NS_IMPL_COCOA EmacsView *view = FRAME_NS_VIEW (f); - NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_begin"); ns_update_auto_hide_menu_bar (); +#ifdef NS_IMPL_COCOA if ([view isFullscreen] && [view fsIsNative]) { // Fix reappearing tool bar in fullscreen for Mac OS X 10.7 @@ -1113,6 +1141,28 @@ ns_update_begin (struct frame *f) [toolbar setVisible: tbar_visible]; } #endif + + ns_updating_frame = f; +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + [view focusOnDrawingBuffer]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + [view lockFocus]; +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif + } @@ -1123,57 +1173,149 @@ ns_update_end (struct frame *f) external (RIF) call; for whole frame, called after gui_update_window_end -------------------------------------------------------------------------- */ { + EmacsView *view = FRAME_NS_VIEW (f); + NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_update_end"); /* if (f == MOUSE_HL_INFO (f)->mouse_face_mouse_frame) */ MOUSE_HL_INFO (f)->mouse_face_defer = 0; -} +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + [NSGraphicsContext setCurrentContext:nil]; + [view setNeedsDisplay:YES]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + block_input (); -static BOOL -ns_clip_to_rect (struct frame *f, NSRect *r, int n) + [view unlockFocus]; + [[view window] flushWindow]; + + unblock_input (); +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif + ns_updating_frame = NULL; +} + +static void +ns_focus (struct frame *f, NSRect *r, int n) /* -------------------------------------------------------------------------- - Clip the drawing area to rectangle r in frame f. If drawing is not - currently possible mark r as dirty and return NO, otherwise return - YES. + Internal: Focus on given frame. During small local updates this is used to + draw, however during large updates, ns_update_begin and ns_update_end are + called to wrap the whole thing, in which case these calls are stubbed out. + Except, on GNUstep, we accumulate the rectangle being drawn into, because + the back end won't do this automatically, and will just end up flushing + the entire window. -------------------------------------------------------------------------- */ { - NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_clip_to_rect"); - if (r) + EmacsView *view = FRAME_NS_VIEW (f); + + NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_focus"); + if (r != NULL) { NSTRACE_RECT ("r", *r); + } - if ([NSView focusView] == FRAME_NS_VIEW (f)) + if (f != ns_updating_frame) + { +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) { - [[NSGraphicsContext currentContext] saveGraphicsState]; - if (n == 2) - NSRectClipList (r, 2); - else - NSRectClip (*r); - - return YES; +#endif + [view focusOnDrawingBuffer]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } else { - NSView *view = FRAME_NS_VIEW (f); - int i; - for (i = 0 ; i < n ; i++) - [view setNeedsDisplayInRect:r[i]]; +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (view != focus_view) + { + if (focus_view != NULL) + { + [focus_view unlockFocus]; + [[focus_view window] flushWindow]; + } + + if (view) + [view lockFocus]; + focus_view = view; + } +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } +#endif } - return NO; + + /* clipping */ + if (r) + { + [[NSGraphicsContext currentContext] saveGraphicsState]; + if (n == 2) + NSRectClipList (r, 2); + else + NSRectClip (*r); + gsaved = YES; + } } static void -ns_reset_clipping (struct frame *f) -/* Internal: Restore the previous graphics state, unsetting any - clipping areas. */ +ns_unfocus (struct frame *f) +/* -------------------------------------------------------------------------- + Internal: Remove focus on given frame + -------------------------------------------------------------------------- */ { - NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_reset_clipping"); + NSTRACE_WHEN (NSTRACE_GROUP_FOCUS, "ns_unfocus"); - [[NSGraphicsContext currentContext] restoreGraphicsState]; + if (gsaved) + { + [[NSGraphicsContext currentContext] restoreGraphicsState]; + gsaved = NO; + } + +#ifdef NS_DRAW_TO_BUFFER + #if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([FRAME_NS_VIEW (f) wantsUpdateLayer]) + { +#endif + [FRAME_NS_VIEW (f) setNeedsDisplay:YES]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ + +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (f != ns_updating_frame) + { + if (focus_view != NULL) + { + [focus_view unlockFocus]; + [[focus_view window] flushWindow]; + focus_view = NULL; + } + } +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif } @@ -1513,9 +1655,12 @@ ns_make_frame_visible (struct frame *f) /* Making a new frame from a fullscreen frame will make the new frame fullscreen also. So skip handleFS as this will print an error. */ - if ([view fsIsNative] && f->want_fullscreen == FULLSCREEN_BOTH - && [view isFullscreen]) - return; + if ([view fsIsNative] && [view isFullscreen]) + { + // maybe it is not necessary to wait + [view waitFullScreenTransition]; + return; + } if (f->want_fullscreen != FULLSCREEN_NONE) { @@ -1680,61 +1825,64 @@ ns_set_offset (struct frame *f, int xoff, int yoff, int change_grav) -------------------------------------------------------------------------- */ { NSView *view = FRAME_NS_VIEW (f); - NSScreen *screen = [[view window] screen]; + NSRect windowFrame = [[view window] frame]; + NSPoint topLeft; NSTRACE ("ns_set_offset"); block_input (); - f->left_pos = xoff; - f->top_pos = yoff; + if (FRAME_PARENT_FRAME (f)) + { + /* Convert the parent frame's view rectangle into screen + coords. */ + EmacsView *parentView = FRAME_NS_VIEW (FRAME_PARENT_FRAME (f)); + NSRect parentRect = [parentView convertRect:[parentView frame] + toView:nil]; + parentRect = [[parentView window] convertRectToScreen:parentRect]; + + if (f->size_hint_flags & XNegative) + topLeft.x = NSMaxX (parentRect) - NSWidth (windowFrame) + xoff; + else + topLeft.x = NSMinX (parentRect) + xoff; - if (view != nil) + if (f->size_hint_flags & YNegative) + topLeft.y = NSMinY (parentRect) + NSHeight (windowFrame) - yoff; + else + topLeft.y = NSMaxY (parentRect) - yoff; + } + else { - if (FRAME_PARENT_FRAME (f) == NULL && screen) - { - f->left_pos = f->size_hint_flags & XNegative - ? [screen visibleFrame].size.width + f->left_pos - FRAME_PIXEL_WIDTH (f) - : f->left_pos; - /* We use visibleFrame here to take menu bar into account. - Ideally we should also adjust left/top with visibleFrame.origin. */ - - f->top_pos = f->size_hint_flags & YNegative - ? ([screen visibleFrame].size.height + f->top_pos - - FRAME_PIXEL_HEIGHT (f) - FRAME_NS_TITLEBAR_HEIGHT (f) - - FRAME_TOOLBAR_HEIGHT (f)) - : f->top_pos; -#ifdef NS_IMPL_GNUSTEP - if (f->left_pos < 100) - f->left_pos = 100; /* don't overlap menu */ -#endif - } - else if (FRAME_PARENT_FRAME (f) != NULL) - { - struct frame *parent = FRAME_PARENT_FRAME (f); + /* If there is no parent frame then just convert to screen + coordinates, UNLESS we have negative values, in which case I + think it's best to position from the bottom and right of the + current screen rather than the main screen or whole + display. */ + NSRect screenFrame = [[[view window] screen] frame]; + + if (f->size_hint_flags & XNegative) + topLeft.x = NSMaxX (screenFrame) - NSWidth (windowFrame) + xoff; + else + topLeft.x = xoff; - /* On X negative values for child frames always result in - positioning relative to the bottom right corner of the - parent frame. */ - if (f->left_pos < 0) - f->left_pos = FRAME_PIXEL_WIDTH (parent) - FRAME_PIXEL_WIDTH (f) + f->left_pos; + if (f->size_hint_flags & YNegative) + topLeft.y = NSMinY (screenFrame) + NSHeight (windowFrame) - yoff; + else + topLeft.y = NSMaxY ([[[NSScreen screens] objectAtIndex:0] frame]) - yoff; - if (f->top_pos < 0) - f->top_pos = FRAME_PIXEL_HEIGHT (parent) + FRAME_TOOLBAR_HEIGHT (parent) - - FRAME_PIXEL_HEIGHT (f) + f->top_pos; - } +#ifdef NS_IMPL_GNUSTEP + /* Don't overlap the menu. - /* Constrain the setFrameTopLeftPoint so we don't move behind the - menu bar. */ - NSPoint pt = NSMakePoint (SCREENMAXBOUND (f->left_pos - + NS_PARENT_WINDOW_LEFT_POS (f)), - SCREENMAXBOUND (NS_PARENT_WINDOW_TOP_POS (f) - - f->top_pos)); - NSTRACE_POINT ("setFrameTopLeftPoint", pt); - [[view window] setFrameTopLeftPoint: pt]; - f->size_hint_flags &= ~(XNegative|YNegative); + FIXME: Surely there's a better way than just hardcoding 100 + in here? */ + topLeft.x = 100; +#endif } + NSTRACE_POINT ("setFrameTopLeftPoint", topLeft); + [[view window] setFrameTopLeftPoint:topLeft]; + f->size_hint_flags &= ~(XNegative|YNegative); + unblock_input (); } @@ -1801,9 +1949,16 @@ ns_set_window_size (struct frame *f, make_fixnum (FRAME_NS_TITLEBAR_HEIGHT (f)), make_fixnum (FRAME_TOOLBAR_HEIGHT (f)))); - [window setFrame: wr display: YES]; + /* Usually it seems safe to delay changing the frame size, but when a + series of actions are taken with no redisplay between them then we + can end up using old values so don't delay here. */ + change_frame_size (f, + FRAME_PIXEL_TO_TEXT_WIDTH (f, pixelwidth), + FRAME_PIXEL_TO_TEXT_HEIGHT (f, pixelheight), + 0, NO, 0, 1); + + [window setFrame:wr display:NO]; - [view updateFrameSize: NO]; unblock_input (); } @@ -1852,7 +2007,6 @@ ns_set_undecorated (struct frame *f, Lisp_Object new_value, Lisp_Object old_valu so some key presses (TAB) are swallowed by the system. */ [window makeFirstResponder: view]; - [view updateFrameSize: NO]; unblock_input (); } } @@ -1901,8 +2055,16 @@ ns_set_parent_frame (struct frame *f, Lisp_Object new_value, Lisp_Object old_val block_input (); child = [FRAME_NS_VIEW (f) window]; +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); +#endif + if ([child parentWindow] != nil) { +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + parent = [child parentWindow]; +#endif + [[child parentWindow] removeChildWindow:child]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 #if MAC_OS_X_VERSION_MIN_REQUIRED < 101000 @@ -1910,10 +2072,38 @@ ns_set_parent_frame (struct frame *f, Lisp_Object new_value, Lisp_Object old_val #endif [child setAccessibilitySubrole:NSAccessibilityStandardWindowSubrole]; #endif +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + if (NILP (new_value)) + { + NSTRACE ("child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary"); + [child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; + // if current parent in fullscreen and no new parent make child fullscreen + while (parent) { + if (([parent styleMask] & NSWindowStyleMaskFullScreen) != 0) + { + [view toggleFullScreen:child]; + break; + } + // check all parents + parent = [parent parentWindow]; + } + } +#endif } if (!NILP (new_value)) { +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + // child frame must not be in fullscreen + if ([view fsIsNative] && [view isFullscreen]) + { + // in case child is going fullscreen + [view waitFullScreenTransition]; + [view toggleFullScreen:child]; + } + NSTRACE ("child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary"); + [child setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary]; +#endif parent = [FRAME_NS_VIEW (p) window]; [parent addChildWindow: child @@ -2014,7 +2204,7 @@ ns_set_appearance (struct frame *f, Lisp_Object new_value, Lisp_Object old_value { #if MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 EmacsView *view = (EmacsView *)FRAME_NS_VIEW (f); - NSWindow *window = [view window]; + EmacsWindow *window = (EmacsWindow *)[view window]; NSTRACE ("ns_set_appearance"); @@ -2026,17 +2216,13 @@ ns_set_appearance (struct frame *f, Lisp_Object new_value, Lisp_Object old_value return; if (EQ (new_value, Qdark)) - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; - FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_vibrant_dark; + else if (EQ (new_value, Qlight)) + FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; else - { - window.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameAqua]; - FRAME_NS_APPEARANCE (f) = ns_appearance_aqua; - } + FRAME_NS_APPEARANCE (f) = ns_appearance_system_default; + + [window setAppearance]; #endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ } @@ -2155,9 +2341,6 @@ ns_get_color (const char *name, NSColor **col) See https://lists.gnu.org/r/emacs-devel/2009-07/msg01203.html. */ { NSColor *new = nil; - static char hex[20]; - int scaling = 0; - float r = -1.0, g, b; NSString *nsname = [NSString stringWithUTF8String: name]; NSTRACE ("ns_get_color(%s, **)", name); @@ -2200,48 +2383,31 @@ ns_get_color (const char *name, NSColor **col) } /* First, check for some sort of numeric specification. */ - hex[0] = '\0'; - - if (name[0] == '0' || name[0] == '1' || name[0] == '.') /* RGB decimal */ + unsigned short r16, g16, b16; + if (parse_color_spec (name, &r16, &g16, &b16)) { - NSScanner *scanner = [NSScanner scannerWithString: nsname]; - [scanner scanFloat: &r]; - [scanner scanFloat: &g]; - [scanner scanFloat: &b]; - } - else if (!strncmp(name, "rgb:", 4)) /* A newer X11 format -- rgb:r/g/b */ - scaling = (snprintf (hex, sizeof hex, "%s", name + 4) - 2) / 3; - else if (name[0] == '#') /* An old X11 format; convert to newer */ - { - int len = (strlen(name) - 1); - int start = (len % 3 == 0) ? 1 : len / 4 + 1; - int i; - scaling = strlen(name+start) / 3; - for (i = 0; i < 3; i++) - sprintf (hex + i * (scaling + 1), "%.*s/", scaling, - name + start + i * scaling); - hex[3 * (scaling + 1) - 1] = '\0'; + *col = [NSColor colorForEmacsRed: r16 / 65535.0 + green: g16 / 65535.0 + blue: b16 / 65535.0 + alpha: 1.0]; + unblock_input (); + return 0; } - - if (hex[0]) + else if (name[0] == '0' || name[0] == '1' || name[0] == '.') { - unsigned int rr, gg, bb; - float fscale = scaling == 4 ? 65535.0 : (scaling == 2 ? 255.0 : 15.0); - if (sscanf (hex, "%x/%x/%x", &rr, &gg, &bb)) + /* RGB decimal */ + NSScanner *scanner = [NSScanner scannerWithString: nsname]; + float r, g, b; + if ( [scanner scanFloat: &r] && r >= 0 && r <= 1 + && [scanner scanFloat: &g] && g >= 0 && g <= 1 + && [scanner scanFloat: &b] && b >= 0 && b <= 1) { - r = rr / fscale; - g = gg / fscale; - b = bb / fscale; + *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; + unblock_input (); + return 0; } } - if (r >= 0.0F) - { - *col = [NSColor colorForEmacsRed: r green: g blue: b alpha: 1.0]; - unblock_input (); - return 0; - } - /* Otherwise, color is expected to be from a list */ { NSEnumerator *lenum, *cenum; @@ -2302,8 +2468,10 @@ ns_color_index_to_rgba(int idx, struct frame *f) EmacsCGFloat r, g, b, a; [col getRed: &r green: &g blue: &b alpha: &a]; - return ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + return ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } void @@ -2323,8 +2491,10 @@ ns_query_color(void *col, Emacs_Color *color_def, bool setPixel) if (setPixel == YES) color_def->pixel - = ARGB_TO_ULONG((int)(a*255), - (int)(r*255), (int)(g*255), (int)(b*255)); + = ARGB_TO_ULONG((unsigned long) (a * 255), + (unsigned long) (r * 255), + (unsigned long) (g * 255), + (unsigned long) (b * 255)); } bool @@ -2478,7 +2648,7 @@ ns_mouse_position (struct frame **fp, int insist, Lisp_Object *bar_window, id view; NSPoint view_position; Lisp_Object frame, tail; - struct frame *f; + struct frame *f = NULL; struct ns_display_info *dpyinfo; NSTRACE ("ns_mouse_position"); @@ -2770,16 +2940,16 @@ ns_clear_frame (struct frame *f) r = [view bounds]; block_input (); - if (ns_clip_to_rect (f, &r, 1)) - { - [ns_lookup_indexed_color (NS_FACE_BACKGROUND - (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; - NSRectFill (r); - ns_reset_clipping (f); - - /* as of 2006/11 or so this is now needed */ - ns_redraw_scroll_bars (f); - } + ns_focus (f, &r, 1); + [ns_lookup_indexed_color (NS_FACE_BACKGROUND + (FACE_FROM_ID (f, DEFAULT_FACE_ID)), f) set]; + NSRectFill (r); + ns_unfocus (f); + + /* as of 2006/11 or so this is now needed */ + /* FIXME: I don't see any reason for this and removing it makes no + difference here. Do we need it for GNUstep? */ + //ns_redraw_scroll_bars (f); unblock_input (); } @@ -2800,46 +2970,15 @@ ns_clear_frame_area (struct frame *f, int x, int y, int width, int height) NSTRACE_WHEN (NSTRACE_GROUP_UPDATES, "ns_clear_frame_area"); r = NSIntersectionRect (r, [view frame]); - if (ns_clip_to_rect (f, &r, 1)) - { - [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; + ns_focus (f, &r, 1); + [ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), f) set]; - NSRectFill (r); + NSRectFill (r); - ns_reset_clipping (f); - } + ns_unfocus (f); + return; } -static void -ns_copy_bits (struct frame *f, NSRect src, NSRect dest) -{ - NSSize delta = NSMakeSize (dest.origin.x - src.origin.x, - dest.origin.y - src.origin.y); - NSTRACE ("ns_copy_bits"); - - if (FRAME_NS_VIEW (f)) - { - hide_bell(); // Ensure the bell image isn't scrolled. - - /* FIXME: scrollRect:by: is deprecated in macOS 10.14. There is - no obvious replacement so we may have to come up with our own. */ - [FRAME_NS_VIEW (f) scrollRect: src by: delta]; - -#ifdef NS_IMPL_COCOA - /* As far as I can tell from the documentation, scrollRect:by:, - above, should copy the dirty rectangles from our source - rectangle to our destination, however it appears it clips the - operation to src. As a result we need to use - translateRectsNeedingDisplayInRect:by: below, and we have to - union src and dest so it can pick up the dirty rectangles, - and place them, as it also clips to the rectangle. - - FIXME: We need a GNUstep equivalent. */ - [FRAME_NS_VIEW (f) translateRectsNeedingDisplayInRect:NSUnionRect (src, dest) - by:delta]; -#endif - } -} static void ns_scroll_run (struct window *w, struct run *run) @@ -2892,8 +3031,12 @@ ns_scroll_run (struct window *w, struct run *run) { NSRect srcRect = NSMakeRect (x, from_y, width, height); NSRect dstRect = NSMakeRect (x, to_y, width, height); + EmacsView *view = FRAME_NS_VIEW (f); - ns_copy_bits (f, srcRect , dstRect); + [view copyRect:srcRect to:dstRect]; +#ifdef NS_IMPL_COCOA + [view setNeedsDisplayInRect:srcRect]; +#endif } unblock_input (); @@ -2947,20 +3090,12 @@ ns_shift_glyphs_for_insert (struct frame *f, External (RIF): copy an area horizontally, don't worry about clearing src -------------------------------------------------------------------------- */ { - //NSRect srcRect = NSMakeRect (x, y, width, height); + NSRect srcRect = NSMakeRect (x, y, width, height); NSRect dstRect = NSMakeRect (x+shift_by, y, width, height); NSTRACE ("ns_shift_glyphs_for_insert"); - /* This doesn't work now as we copy the "bits" before we've had a - chance to actually draw any changes to the screen. This means in - certain circumstances we end up with copies of the cursor all - over the place. Just mark the area dirty so it is redrawn later. - - FIXME: Work out how to do this properly. */ - // ns_copy_bits (f, srcRect, dstRect); - - [FRAME_NS_VIEW (f) setNeedsDisplayInRect:dstRect]; + [FRAME_NS_VIEW (f) copyRect:srcRect to:dstRect]; } @@ -3080,66 +3215,64 @@ ns_draw_fringe_bitmap (struct window *w, struct glyph_row *row, /* The visible portion of imageRect will always be contained within clearRect. */ - if (ns_clip_to_rect (f, &clearRect, 1)) + ns_focus (f, &clearRect, 1); + if (! NSIsEmptyRect (clearRect)) { - if (! NSIsEmptyRect (clearRect)) - { - NSTRACE_RECT ("clearRect", clearRect); + NSTRACE_RECT ("clearRect", clearRect); - [ns_lookup_indexed_color(face->background, f) set]; - NSRectFill (clearRect); - } + [ns_lookup_indexed_color(face->background, f) set]; + NSRectFill (clearRect); + } - if (p->which) - { - EmacsImage *img = bimgs[p->which - 1]; + if (p->which) + { + EmacsImage *img = bimgs[p->which - 1]; - if (!img) - { - // Note: For "periodic" images, allocate one EmacsImage for - // the base image, and use it for all dh:s. - unsigned short *bits = p->bits; - int full_height = p->h + p->dh; - int i; - unsigned char *cbits = xmalloc (full_height); - - for (i = 0; i < full_height; i++) - cbits[i] = bits[i]; - img = [[EmacsImage alloc] initFromXBM: cbits width: 8 - height: full_height - fg: 0 bg: 0 - reverseBytes: NO]; - bimgs[p->which - 1] = img; - xfree (cbits); - } + if (!img) + { + // Note: For "periodic" images, allocate one EmacsImage for + // the base image, and use it for all dh:s. + unsigned short *bits = p->bits; + int full_height = p->h + p->dh; + int i; + unsigned char *cbits = xmalloc (full_height); + + for (i = 0; i < full_height; i++) + cbits[i] = bits[i]; + img = [[EmacsImage alloc] initFromXBM: cbits width: 8 + height: full_height + fg: 0 bg: 0 + reverseBytes: NO]; + bimgs[p->which - 1] = img; + xfree (cbits); + } - { - NSColor *bm_color; - if (!p->cursor_p) - bm_color = ns_lookup_indexed_color(face->foreground, f); - else if (p->overlay_p) - bm_color = ns_lookup_indexed_color(face->background, f); - else - bm_color = f->output_data.ns->cursor_color; - [img setXBMColor: bm_color]; - } + { + NSColor *bm_color; + if (!p->cursor_p) + bm_color = ns_lookup_indexed_color(face->foreground, f); + else if (p->overlay_p) + bm_color = ns_lookup_indexed_color(face->background, f); + else + bm_color = f->output_data.ns->cursor_color; + [img setXBMColor: bm_color]; + } - // Note: For periodic images, the full image height is "h + hd". - // By using the height h, a suitable part of the image is used. - NSRect fromRect = NSMakeRect(0, 0, p->wd, p->h); + // Note: For periodic images, the full image height is "h + hd". + // By using the height h, a suitable part of the image is used. + NSRect fromRect = NSMakeRect(0, 0, p->wd, p->h); - NSTRACE_RECT ("fromRect", fromRect); + NSTRACE_RECT ("fromRect", fromRect); - [img drawInRect: imageRect - fromRect: fromRect - operation: NSCompositingOperationSourceOver - fraction: 1.0 - respectFlipped: YES - hints: nil]; - } - ns_reset_clipping (f); + [img drawInRect: imageRect + fromRect: fromRect + operation: NSCompositingOperationSourceOver + fraction: 1.0 + respectFlipped: YES + hints: nil]; } + ns_unfocus (f); } @@ -3224,60 +3357,52 @@ ns_draw_window_cursor (struct window *w, struct glyph_row *glyph_row, /* Prevent the cursor from being drawn outside the text area. */ r = NSIntersectionRect (r, ns_row_rect (w, glyph_row, TEXT_AREA)); - if (ns_clip_to_rect (f, &r, 1)) + face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); + if (face && NS_FACE_BACKGROUND (face) + == ns_index_color (FRAME_CURSOR_COLOR (f), f)) { - face = FACE_FROM_ID_OR_NULL (f, phys_cursor_glyph->face_id); - if (face && NS_FACE_BACKGROUND (face) - == ns_index_color (FRAME_CURSOR_COLOR (f), f)) - { - [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; - hollow_color = FRAME_CURSOR_COLOR (f); - } - else - [FRAME_CURSOR_COLOR (f) set]; - - switch (cursor_type) - { - case DEFAULT_CURSOR: - case NO_CURSOR: - break; - case FILLED_BOX_CURSOR: - NSRectFill (r); - break; - case HOLLOW_BOX_CURSOR: - NSRectFill (r); - [hollow_color set]; - NSRectFill (NSInsetRect (r, 1, 1)); - [FRAME_CURSOR_COLOR (f) set]; - break; - case HBAR_CURSOR: - NSRectFill (r); - break; - case BAR_CURSOR: - s = r; - /* If the character under cursor is R2L, draw the bar cursor - on the right of its glyph, rather than on the left. */ - cursor_glyph = get_phys_cursor_glyph (w); - if ((cursor_glyph->resolved_level & 1) != 0) - s.origin.x += cursor_glyph->pixel_width - s.size.width; - - NSRectFill (s); - break; - } + [ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), f) set]; + hollow_color = FRAME_CURSOR_COLOR (f); + } + else + [FRAME_CURSOR_COLOR (f) set]; - /* Draw the character under the cursor. Other terms only draw - the character on top of box cursors, so do the same here. */ - if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR) - draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); + ns_focus (f, &r, 1); - ns_reset_clipping (f); - } - else if (! redisplaying_p) + switch (cursor_type) { - /* If this function is called outside redisplay, it probably - means we need an immediate update. */ - [FRAME_NS_VIEW (f) display]; + case DEFAULT_CURSOR: + case NO_CURSOR: + break; + case FILLED_BOX_CURSOR: + NSRectFill (r); + break; + case HOLLOW_BOX_CURSOR: + NSRectFill (r); + [hollow_color set]; + NSRectFill (NSInsetRect (r, 1, 1)); + [FRAME_CURSOR_COLOR (f) set]; + break; + case HBAR_CURSOR: + NSRectFill (r); + break; + case BAR_CURSOR: + s = r; + /* If the character under cursor is R2L, draw the bar cursor + on the right of its glyph, rather than on the left. */ + cursor_glyph = get_phys_cursor_glyph (w); + if ((cursor_glyph->resolved_level & 1) != 0) + s.origin.x += cursor_glyph->pixel_width - s.size.width; + + NSRectFill (s); + break; } + ns_unfocus (f); + + /* Draw the character under the cursor. Other terms only draw + the character on top of box cursors, so do the same here. */ + if (cursor_type == FILLED_BOX_CURSOR || cursor_type == HOLLOW_BOX_CURSOR) + draw_phys_cursor_glyph (w, glyph_row, DRAW_CURSOR); } @@ -3295,14 +3420,12 @@ ns_draw_vertical_window_border (struct window *w, int x, int y0, int y1) face = FACE_FROM_ID_OR_NULL (f, VERTICAL_BORDER_FACE_ID); - if (ns_clip_to_rect (f, &r, 1)) - { - if (face) - [ns_lookup_indexed_color(face->foreground, f) set]; + ns_focus (f, &r, 1); + if (face) + [ns_lookup_indexed_color(face->foreground, f) set]; - NSRectFill(r); - ns_reset_clipping (f); - } + NSRectFill(r); + ns_unfocus (f); } @@ -3329,42 +3452,42 @@ ns_draw_window_divider (struct window *w, int x0, int x1, int y0, int y1) NSTRACE ("ns_draw_window_divider"); - if (ns_clip_to_rect (f, ÷r, 1)) - { - if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) - /* A vertical divider, at least three pixels wide: Draw first and - last pixels differently. */ - { - [ns_lookup_indexed_color(color_first, f) set]; - NSRectFill(NSMakeRect (x0, y0, 1, y1 - y0)); - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(NSMakeRect (x0 + 1, y0, x1 - x0 - 2, y1 - y0)); - [ns_lookup_indexed_color(color_last, f) set]; - NSRectFill(NSMakeRect (x1 - 1, y0, 1, y1 - y0)); - } - else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) - /* A horizontal divider, at least three pixels high: Draw first and - last pixels differently. */ - { - [ns_lookup_indexed_color(color_first, f) set]; - NSRectFill(NSMakeRect (x0, y0, x1 - x0, 1)); - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(NSMakeRect (x0, y0 + 1, x1 - x0, y1 - y0 - 2)); - [ns_lookup_indexed_color(color_last, f) set]; - NSRectFill(NSMakeRect (x0, y1 - 1, x1 - x0, 1)); - } - else - { - /* In any other case do not draw the first and last pixels - differently. */ - [ns_lookup_indexed_color(color, f) set]; - NSRectFill(divider); - } + ns_focus (f, ÷r, 1); - ns_reset_clipping (f); + if ((y1 - y0 > x1 - x0) && (x1 - x0 >= 3)) + /* A vertical divider, at least three pixels wide: Draw first and + last pixels differently. */ + { + [ns_lookup_indexed_color(color_first, f) set]; + NSRectFill(NSMakeRect (x0, y0, 1, y1 - y0)); + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(NSMakeRect (x0 + 1, y0, x1 - x0 - 2, y1 - y0)); + [ns_lookup_indexed_color(color_last, f) set]; + NSRectFill(NSMakeRect (x1 - 1, y0, 1, y1 - y0)); + } + else if ((x1 - x0 > y1 - y0) && (y1 - y0 >= 3)) + /* A horizontal divider, at least three pixels high: Draw first and + last pixels differently. */ + { + [ns_lookup_indexed_color(color_first, f) set]; + NSRectFill(NSMakeRect (x0, y0, x1 - x0, 1)); + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(NSMakeRect (x0, y0 + 1, x1 - x0, y1 - y0 - 2)); + [ns_lookup_indexed_color(color_last, f) set]; + NSRectFill(NSMakeRect (x0, y1 - 1, x1 - x0, 1)); } + else + { + /* In any other case do not draw the first and last pixels + differently. */ + [ns_lookup_indexed_color(color, f) set]; + NSRectFill(divider); + } + + ns_unfocus (f); } + static void ns_show_hourglass (struct frame *f) { @@ -3589,8 +3712,8 @@ ns_draw_text_decoration (struct glyph_string *s, struct face *face, } static void -ns_draw_box (NSRect r, CGFloat thickness, NSColor *col, - char left_p, char right_p) +ns_draw_box (NSRect r, CGFloat hthickness, CGFloat vthickness, + NSColor *col, char left_p, char right_p) /* -------------------------------------------------------------------------- Draw an unfilled rect inside r, optionally leaving left and/or right open. Note we can't just use an NSDrawRect command, because of the possibility @@ -3601,28 +3724,28 @@ ns_draw_box (NSRect r, CGFloat thickness, NSColor *col, [col set]; /* top, bottom */ - s.size.height = thickness; + s.size.height = hthickness; NSRectFill (s); - s.origin.y += r.size.height - thickness; + s.origin.y += r.size.height - hthickness; NSRectFill (s); s.size.height = r.size.height; s.origin.y = r.origin.y; /* left, right (optional) */ - s.size.width = thickness; + s.size.width = vthickness; if (left_p) NSRectFill (s); if (right_p) { - s.origin.x += r.size.width - thickness; + s.origin.x += r.size.width - vthickness; NSRectFill (s); } } static void -ns_draw_relief (NSRect r, int thickness, char raised_p, +ns_draw_relief (NSRect r, int hthickness, int vthickness, char raised_p, char top_p, char bottom_p, char left_p, char right_p, struct glyph_string *s) /* -------------------------------------------------------------------------- @@ -3672,27 +3795,27 @@ ns_draw_relief (NSRect r, int thickness, char raised_p, /* TODO: mitering. Using NSBezierPath doesn't work because of color switch. */ /* top */ - sr.size.height = thickness; + sr.size.height = hthickness; if (top_p) NSRectFill (sr); /* left */ sr.size.height = r.size.height; - sr.size.width = thickness; + sr.size.width = vthickness; if (left_p) NSRectFill (sr); [(raised_p ? darkCol : lightCol) set]; /* bottom */ sr.size.width = r.size.width; - sr.size.height = thickness; - sr.origin.y += r.size.height - thickness; + sr.size.height = hthickness; + sr.origin.y += r.size.height - hthickness; if (bottom_p) NSRectFill (sr); /* right */ sr.size.height = r.size.height; sr.origin.y = r.origin.y; - sr.size.width = thickness; - sr.origin.x += r.size.width - thickness; + sr.size.width = vthickness; + sr.origin.x += r.size.width - vthickness; if (right_p) NSRectFill (sr); } @@ -3708,7 +3831,7 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) char left_p, right_p; struct glyph *last_glyph; NSRect r; - int thickness; + int hthickness, vthickness; struct face *face; if (s->hl == DRAW_MOUSE_FACE) @@ -3721,15 +3844,29 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) else face = s->face; - thickness = face->box_line_width; + vthickness = face->box_vertical_line_width; + hthickness = face->box_horizontal_line_width; NSTRACE ("ns_dumpglyphs_box_or_relief"); last_x = ((s->row->full_width_p && !s->w->pseudo_window_p) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - last_glyph = (s->cmp || s->img - ? s->first_glyph : s->first_glyph + s->nchars-1); + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; right_x = ((s->row->full_width_p && s->extends_to_end_of_line_p ? last_x - 1 : min (last_x, s->x + s->background_width) - 1)); @@ -3746,14 +3883,15 @@ ns_dumpglyphs_box_or_relief (struct glyph_string *s) /* TODO: Sometimes box_color is 0 and this seems wrong; should investigate. */ if (s->face->box == FACE_SIMPLE_BOX && s->face->box_color) { - ns_draw_box (r, abs (thickness), + ns_draw_box (r, abs (hthickness), abs (vthickness), ns_lookup_indexed_color (face->box_color, s->f), - left_p, right_p); + left_p, right_p); } else { - ns_draw_relief (r, abs (thickness), s->face->box == FACE_RAISED_BOX, - 1, 1, left_p, right_p, s); + ns_draw_relief (r, abs (hthickness), abs (vthickness), + s->face->box == FACE_RAISED_BOX, + 1, 1, left_p, right_p, s); } } @@ -3769,7 +3907,7 @@ ns_maybe_dumpglyphs_background (struct glyph_string *s, char force_p) if (!s->background_filled_p/* || s->hl == DRAW_MOUSE_FACE*/) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (FONT_HEIGHT (s->font) < s->height - 2 * box_line_width /* When xdisp.c ignores FONT_HEIGHT, we cannot trust font dimensions, since the actual glyphs might be much @@ -3820,7 +3958,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) -------------------------------------------------------------------------- */ { EmacsImage *img = s->img->pixmap; - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int x = s->x, y = s->ybase - image_ascent (s->img, s->face, &s->slice); int bg_x, bg_y, bg_height; int th; @@ -3833,7 +3971,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += abs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); bg_x = x; bg_y = s->slice.y == 0 ? s->y : s->y + box_line_vwidth; @@ -3888,15 +4026,22 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) [[NSGraphicsContext currentContext] saveGraphicsState]; - /* Because of the transforms it's far too difficult to work out - what portion of the original, untransformed, image will be - drawn, so the clipping area will ensure we draw only the - correct bit. */ + /* Because of the transforms it's difficult to work out what + portion of the original, untransformed, image will be drawn, + so the clipping area will ensure we draw only the correct + bit. */ NSRectClip (dr); [setOrigin translateXBy:x - s->slice.x yBy:y - s->slice.y]; [setOrigin concat]; - [img->transform concat]; + + NSAffineTransform *doTransform = [NSAffineTransform transform]; + + /* ImageMagick images don't have transforms. */ + if (img->transform) + [doTransform appendTransform:img->transform]; + + [doTransform concat]; [img drawInRect:ir fromRect:ir operation:NSCompositingOperationSourceOver @@ -3946,7 +4091,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) r.origin.y = y - th; r.size.width = s->slice.width + 2*th-1; r.size.height = s->slice.height + 2*th-1; - ns_draw_relief (r, th, raised_p, + ns_draw_relief (r, th, th, raised_p, s->slice.y == 0, s->slice.y + s->slice.height == s->img->height, s->slice.x == 0, @@ -3960,7 +4105,7 @@ ns_dumpglyphs_image (struct glyph_string *s, NSRect r) { int thickness = abs (s->img->relief); if (thickness == 0) thickness = 1; - ns_draw_box (br, thickness, FRAME_CURSOR_COLOR (s->f), 1, 1); + ns_draw_box (br, thickness, thickness, FRAME_CURSOR_COLOR (s->f), 1, 1); } } @@ -3969,89 +4114,65 @@ static void ns_dumpglyphs_stretch (struct glyph_string *s) { NSRect r[2]; - int n, i; + NSRect glyphRect; + int n; struct face *face; NSColor *fgCol, *bgCol; if (!s->background_filled_p) { n = ns_get_glyph_string_clip_rect (s, r); + ns_focus (s->f, r, n); - if (ns_clip_to_rect (s->f, r, n)) + if (s->hl == DRAW_MOUSE_FACE) { - /* FIXME: Why are we reusing the clipping rectangles? The - other terms don't appear to do anything like this. */ - *r = NSMakeRect (s->x, s->y, s->background_width, s->height); + face = FACE_FROM_ID_OR_NULL (s->f, + MOUSE_HL_INFO (s->f)->mouse_face_face_id); + if (!face) + face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); + } + else + face = FACE_FROM_ID (s->f, s->first_glyph->face_id); - if (s->hl == DRAW_MOUSE_FACE) - { - face = FACE_FROM_ID_OR_NULL (s->f, - MOUSE_HL_INFO (s->f)->mouse_face_face_id); - if (!face) - face = FACE_FROM_ID (s->f, MOUSE_FACE_ID); - } - else - face = FACE_FROM_ID (s->f, s->first_glyph->face_id); + bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); + fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); - bgCol = ns_lookup_indexed_color (NS_FACE_BACKGROUND (face), s->f); - fgCol = ns_lookup_indexed_color (NS_FACE_FOREGROUND (face), s->f); + glyphRect = NSMakeRect (s->x, s->y, s->background_width, s->height); - for (i = 0; i < n; ++i) - { - if (!s->row->full_width_p) - { - int overrun, leftoverrun; - - /* truncate to avoid overwriting fringe and/or scrollbar */ - overrun = max (0, (s->x + s->background_width) - - (WINDOW_BOX_RIGHT_EDGE_X (s->w) - - WINDOW_RIGHT_FRINGE_WIDTH (s->w))); - r[i].size.width -= overrun; - - /* truncate to avoid overwriting to left of the window box */ - leftoverrun = (WINDOW_BOX_LEFT_EDGE_X (s->w) - + WINDOW_LEFT_FRINGE_WIDTH (s->w)) - s->x; - - if (leftoverrun > 0) - { - r[i].origin.x += leftoverrun; - r[i].size.width -= leftoverrun; - } - } + [bgCol set]; - [bgCol set]; + /* NOTE: under NS this is NOT used to draw cursors, but we must avoid + overwriting cursor (usually when cursor on a tab) */ + if (s->hl == DRAW_CURSOR) + { + CGFloat x, width; - /* NOTE: under NS this is NOT used to draw cursors, but we must avoid - overwriting cursor (usually when cursor on a tab). */ - if (s->hl == DRAW_CURSOR) - { - CGFloat x, width; + /* FIXME: This looks like it will only work for left to + right languages. */ + x = NSMinX (glyphRect); + width = s->w->phys_cursor_width; + glyphRect.size.width -= width; + glyphRect.origin.x += width; - x = r[i].origin.x; - width = s->w->phys_cursor_width; - r[i].size.width -= width; - r[i].origin.x += width; + NSRectFill (glyphRect); - NSRectFill (r[i]); + /* Draw overlining, etc. on the cursor. */ + if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) + ns_draw_text_decoration (s, face, bgCol, width, x); + else + ns_draw_text_decoration (s, face, fgCol, width, x); + } + else + { + NSRectFill (glyphRect); + } - /* Draw overlining, etc. on the cursor. */ - if (s->w->phys_cursor_type == FILLED_BOX_CURSOR) - ns_draw_text_decoration (s, face, bgCol, width, x); - else - ns_draw_text_decoration (s, face, fgCol, width, x); - } - else - { - NSRectFill (r[i]); - } + /* Draw overlining, etc. on the stretch glyph (or the part + of the stretch glyph after the cursor). */ + ns_draw_text_decoration (s, face, fgCol, NSWidth (glyphRect), + NSMinX (glyphRect)); - /* Draw overlining, etc. on the stretch glyph (or the part - of the stretch glyph after the cursor). */ - ns_draw_text_decoration (s, face, fgCol, r[i].size.width, - r[i].origin.x); - } - ns_reset_clipping (s->f); - } + ns_unfocus (s->f); s->background_filled_p = 1; } } @@ -4067,7 +4188,7 @@ ns_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -4093,7 +4214,7 @@ ns_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -4109,7 +4230,7 @@ ns_draw_composite_glyph_string_foreground (struct glyph_string *s) if (s->cmp_from == 0) { NSRect r = NSMakeRect (s->x, s->y, s->width-1, s->height -1); - ns_draw_box (r, 1, FRAME_CURSOR_COLOR (s->f), 1, 1); + ns_draw_box (r, 1, 1, FRAME_CURSOR_COLOR (s->f), 1, 1); } } else if (! s->first_glyph->u.cmp.automatic) @@ -4201,11 +4322,9 @@ ns_draw_glyph_string (struct glyph_string *s) if (next->first_glyph->type != STRETCH_GLYPH) { n = ns_get_glyph_string_clip_rect (s->next, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_maybe_dumpglyphs_background (s->next, 1); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_maybe_dumpglyphs_background (s->next, 1); + ns_unfocus (s->f); } else { @@ -4220,12 +4339,10 @@ ns_draw_glyph_string (struct glyph_string *s) || s->first_glyph->type == COMPOSITE_GLYPH)) { n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_maybe_dumpglyphs_background (s, 1); - ns_dumpglyphs_box_or_relief (s); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_maybe_dumpglyphs_background (s, 1); + ns_dumpglyphs_box_or_relief (s); + ns_unfocus (s->f); box_drawn_p = 1; } @@ -4234,11 +4351,9 @@ ns_draw_glyph_string (struct glyph_string *s) case IMAGE_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_dumpglyphs_image (s, r[0]); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_dumpglyphs_image (s, r[0]); + ns_unfocus (s->f); break; case STRETCH_GLYPH: @@ -4248,68 +4363,66 @@ ns_draw_glyph_string (struct glyph_string *s) case CHAR_GLYPH: case COMPOSITE_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - if (s->for_overlaps || (s->cmp_from > 0 - && ! s->first_glyph->u.cmp.automatic)) - s->background_filled_p = 1; - else - ns_maybe_dumpglyphs_background - (s, s->first_glyph->type == COMPOSITE_GLYPH); + ns_focus (s->f, r, n); - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + ns_maybe_dumpglyphs_background + (s, s->first_glyph->type == COMPOSITE_GLYPH); - { - BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; + if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) + { + unsigned long tmp = NS_FACE_BACKGROUND (s->face); + NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); + NS_FACE_FOREGROUND (s->face) = tmp; + } - if (isComposite) - ns_draw_composite_glyph_string_foreground (s); - else - ns_draw_glyph_string_foreground (s); - } + { + BOOL isComposite = s->first_glyph->type == COMPOSITE_GLYPH; - { - NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 - ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), - s->f) - : FRAME_FOREGROUND_COLOR (s->f)); - [col set]; - - /* Draw underline, overline, strike-through. */ - ns_draw_text_decoration (s, s->face, col, s->width, s->x); - } + if (isComposite) + ns_draw_composite_glyph_string_foreground (s); + else + ns_draw_glyph_string_foreground (s); + } - if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) - { - unsigned long tmp = NS_FACE_BACKGROUND (s->face); - NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); - NS_FACE_FOREGROUND (s->face) = tmp; - } + { + NSColor *col = (NS_FACE_FOREGROUND (s->face) != 0 + ? ns_lookup_indexed_color (NS_FACE_FOREGROUND (s->face), + s->f) + : FRAME_FOREGROUND_COLOR (s->f)); + [col set]; + + /* Draw underline, overline, strike-through. */ + ns_draw_text_decoration (s, s->face, col, s->width, s->x); + } - ns_reset_clipping (s->f); + if (s->hl == DRAW_CURSOR && s->w->phys_cursor_type == FILLED_BOX_CURSOR) + { + unsigned long tmp = NS_FACE_BACKGROUND (s->face); + NS_FACE_BACKGROUND (s->face) = NS_FACE_FOREGROUND (s->face); + NS_FACE_FOREGROUND (s->face) = tmp; } + + ns_unfocus (s->f); break; case GLYPHLESS_GLYPH: n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - if (s->for_overlaps || (s->cmp_from > 0 - && ! s->first_glyph->u.cmp.automatic)) - s->background_filled_p = 1; - else - ns_maybe_dumpglyphs_background - (s, s->first_glyph->type == COMPOSITE_GLYPH); - /* ... */ - /* Not yet implemented. */ - /* ... */ - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + + if (s->for_overlaps || (s->cmp_from > 0 + && ! s->first_glyph->u.cmp.automatic)) + s->background_filled_p = 1; + else + ns_maybe_dumpglyphs_background + (s, s->first_glyph->type == COMPOSITE_GLYPH); + /* ... */ + /* Not yet implemented. */ + /* ... */ + ns_unfocus (s->f); break; default: @@ -4320,11 +4433,9 @@ ns_draw_glyph_string (struct glyph_string *s) if (!s->for_overlaps && !box_drawn_p && s->face->box != FACE_NO_BOX) { n = ns_get_glyph_string_clip_rect (s, r); - if (ns_clip_to_rect (s->f, r, n)) - { - ns_dumpglyphs_box_or_relief (s); - ns_reset_clipping (s->f); - } + ns_focus (s->f, r, n); + ns_dumpglyphs_box_or_relief (s); + ns_unfocus (s->f); } s->num_clips = 0; @@ -5001,9 +5112,6 @@ ns_judge_scroll_bars (struct frame *f) if ([view judge]) removed = YES; } - - if (removed) - [eview updateFrameSize: NO]; } /* ========================================================================== @@ -5396,7 +5504,7 @@ ns_term_init (Lisp_Object display_name) } /* FIXME: Report any errors writing the color file below. */ -#if MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101100 #if MAC_OS_X_VERSION_MIN_REQUIRED < 101100 if ([cl respondsToSelector:@selector(writeToURL:error:)]) #endif @@ -6190,6 +6298,17 @@ not_in_argv (NSString *arg) - (void)dealloc { NSTRACE ("[EmacsView dealloc]"); + + /* Clear the view resize notification. */ + [[NSNotificationCenter defaultCenter] + removeObserver:self + name:NSViewFrameDidChangeNotification + object:nil]; + +#ifdef NS_DRAW_TO_BUFFER + CGContextRelease (drawingBuffer); +#endif + [toolbar release]; if (fs_state == FULLSCREEN_BOTH) [nonfs_window release]; @@ -6606,13 +6725,18 @@ not_in_argv (NSString *arg) { NSRect rect; NSPoint pt; - struct window *win = XWINDOW (FRAME_SELECTED_WINDOW (emacsframe)); + struct window *win; NSTRACE ("[EmacsView firstRectForCharacterRange:]"); if (NS_KEYLOG) NSLog (@"firstRectForCharRange request"); + if (WINDOWP (echo_area_window) && ! NILP (call0 (intern ("ns-in-echo-area")))) + win = XWINDOW (echo_area_window); + else + win = XWINDOW (FRAME_SELECTED_WINDOW (emacsframe)); + rect.size.width = theRange.length * FRAME_COLUMN_WIDTH (emacsframe); rect.size.height = FRAME_LINE_HEIGHT (emacsframe); pt.x = WINDOW_TEXT_TO_FRAME_PIXEL_X (win, win->phys_cursor.x); @@ -6719,8 +6843,6 @@ not_in_argv (NSString *arg) NSTRACE ("[EmacsView mouseDown:]"); - [self deleteWorkingText]; - if (!emacs_event) return; @@ -7028,105 +7150,12 @@ not_in_argv (NSString *arg) return NO; } -- (void) updateFrameSize: (BOOL) delay -{ - NSWindow *window = [self window]; - NSRect wr = [window frame]; - int extra = 0; - int oldc = cols, oldr = rows; - int oldw = FRAME_PIXEL_WIDTH (emacsframe); - int oldh = FRAME_PIXEL_HEIGHT (emacsframe); - int neww, newh; - - NSTRACE ("[EmacsView updateFrameSize:]"); - NSTRACE_SIZE ("Original size", NSMakeSize (oldw, oldh)); - NSTRACE_RECT ("Original frame", wr); - NSTRACE_MSG ("Original columns: %d", cols); - NSTRACE_MSG ("Original rows: %d", rows); - - if (! [self isFullscreen]) - { - int toolbar_height; -#ifdef NS_IMPL_GNUSTEP - // GNUstep does not always update the tool bar height. Force it. - if (toolbar && [toolbar isVisible]) - update_frame_tool_bar (emacsframe); -#endif - - toolbar_height = FRAME_TOOLBAR_HEIGHT (emacsframe); - if (toolbar_height < 0) - toolbar_height = 35; - - extra = FRAME_NS_TITLEBAR_HEIGHT (emacsframe) - + toolbar_height; - } - - if (wait_for_tool_bar) - { - /* The toolbar height is always 0 in fullscreen and undecorated - frames, so don't wait for it to become available. */ - if (FRAME_TOOLBAR_HEIGHT (emacsframe) == 0 - && FRAME_UNDECORATED (emacsframe) == false - && ! [self isFullscreen]) - { - NSTRACE_MSG ("Waiting for toolbar"); - return; - } - wait_for_tool_bar = NO; - } - - neww = (int)wr.size.width - emacsframe->border_width; - newh = (int)wr.size.height - extra; - - NSTRACE_SIZE ("New size", NSMakeSize (neww, newh)); - NSTRACE_MSG ("FRAME_TOOLBAR_HEIGHT: %d", FRAME_TOOLBAR_HEIGHT (emacsframe)); - NSTRACE_MSG ("FRAME_NS_TITLEBAR_HEIGHT: %d", FRAME_NS_TITLEBAR_HEIGHT (emacsframe)); - - cols = FRAME_PIXEL_WIDTH_TO_TEXT_COLS (emacsframe, neww); - rows = FRAME_PIXEL_HEIGHT_TO_TEXT_LINES (emacsframe, newh); - - if (cols < MINWIDTH) - cols = MINWIDTH; - - if (rows < MINHEIGHT) - rows = MINHEIGHT; - - NSTRACE_MSG ("New columns: %d", cols); - NSTRACE_MSG ("New rows: %d", rows); - - if (oldr != rows || oldc != cols || neww != oldw || newh != oldh) - { - NSView *view = FRAME_NS_VIEW (emacsframe); - - change_frame_size (emacsframe, - FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww), - FRAME_PIXEL_TO_TEXT_HEIGHT (emacsframe, newh), - 0, delay, 0, 1); - SET_FRAME_GARBAGED (emacsframe); - cancel_mouse_face (emacsframe); - - /* The next two lines set the frame to the same size as we've - already set above. We need to do this when we switch back - from non-native fullscreen, in other circumstances it appears - to be a noop. (bug#28872) */ - wr = NSMakeRect (0, 0, neww, newh); - [view setFrame: wr]; - - // To do: consider using [NSNotificationCenter postNotificationName:]. - [self windowDidMove: // Update top/left. - [NSNotification notificationWithName:NSWindowDidMoveNotification - object:[view window]]]; - } - else - { - NSTRACE_MSG ("No change"); - } -} - (NSSize)windowWillResize: (NSWindow *)sender toSize: (NSSize)frameSize /* Normalize frame to gridded text size. */ { int extra = 0; + int cols, rows; NSTRACE ("[EmacsView windowWillResize:toSize: " NSTRACE_FMT_SIZE "]", NSTRACE_ARG_SIZE (frameSize)); @@ -7192,6 +7221,7 @@ not_in_argv (NSString *arg) size_title = xmalloc (strlen (old_title) + 40); esprintf (size_title, "%s — (%d x %d)", old_title, cols, rows); [window setTitle: [NSString stringWithUTF8String: size_title]]; + [window display]; xfree (size_title); } } @@ -7262,11 +7292,6 @@ not_in_argv (NSString *arg) sz = [self windowWillResize: theWindow toSize: sz]; #endif /* NS_IMPL_GNUSTEP */ - if (cols > 0 && rows > 0) - { - [self updateFrameSize: YES]; - } - ns_send_appdefined (-1); } @@ -7287,6 +7312,55 @@ not_in_argv (NSString *arg) #endif /* NS_IMPL_COCOA */ +- (void)viewDidResize:(NSNotification *)notification +{ + NSRect frame = [self frame]; + int neww, newh; + + if (! FRAME_LIVE_P (emacsframe)) + return; + + NSTRACE ("[EmacsView viewDidResize]"); + + neww = (int)NSWidth (frame); + newh = (int)NSHeight (frame); + NSTRACE_SIZE ("New size", NSMakeSize (neww, newh)); + +#ifdef NS_DRAW_TO_BUFFER + if ([self wantsUpdateLayer]) + { + CGFloat scale = [[self window] backingScaleFactor]; + int oldw = (CGFloat)CGBitmapContextGetWidth (drawingBuffer) / scale; + int oldh = (CGFloat)CGBitmapContextGetHeight (drawingBuffer) / scale; + + NSTRACE_SIZE ("Original size", NSMakeSize (oldw, oldh)); + + /* Don't want to do anything when the view size hasn't changed. */ + if ((oldh == newh && oldw == neww)) + { + NSTRACE_MSG ("No change"); + return; + } + } +#endif + + /* I'm not sure if it's safe to call this every time the view + changes size, as Emacs may already know about the change. + Unfortunately there doesn't seem to be a bullet-proof method of + determining whether we need to call it or not. */ + change_frame_size (emacsframe, + FRAME_PIXEL_TO_TEXT_WIDTH (emacsframe, neww), + FRAME_PIXEL_TO_TEXT_HEIGHT (emacsframe, newh), + 0, YES, 0, 1); + +#ifdef NS_DRAW_TO_BUFFER + [self createDrawingBuffer]; +#endif + SET_FRAME_GARBAGED (emacsframe); + cancel_mouse_face (emacsframe); +} + + - (void)windowDidBecomeKey: (NSNotification *)notification /* cf. x_detect_focus_change(), x_focus_changed(), x_new_focus_frame() */ { @@ -7345,7 +7419,6 @@ not_in_argv (NSString *arg) if (emacs_event && is_focus_frame) { - [self deleteWorkingText]; emacs_event->kind = FOCUS_OUT_EVENT; EV_TRAILER ((id)nil); } @@ -7411,7 +7484,7 @@ not_in_argv (NSString *arg) { NSRect r, wr; Lisp_Object tem; - NSWindow *win; + EmacsWindow *win; NSColor *col; NSString *name; @@ -7431,6 +7504,7 @@ not_in_argv (NSString *arg) #endif fs_is_native = ns_use_native_fullscreen; #endif + in_fullscreen_transition = NO; maximized_width = maximized_height = -1; nonfs_window = nil; @@ -7460,7 +7534,10 @@ not_in_argv (NSString *arg) #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 if (NSAppKitVersionNumber >= NSAppKitVersionNumber10_7) #endif - [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; + if (FRAME_PARENT_FRAME (f)) + [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenAuxiliary]; + else + [win setCollectionBehavior:NSWindowCollectionBehaviorFullScreenPrimary]; #endif wr = [win frame]; @@ -7489,16 +7566,8 @@ not_in_argv (NSString *arg) if (! FRAME_UNDECORATED (f)) [self createToolbar: f]; -#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 -#ifndef NSAppKitVersionNumber10_10 -#define NSAppKitVersionNumber10_10 1343 -#endif - if (NSAppKitVersionNumber >= NSAppKitVersionNumber10_10 - && FRAME_NS_APPEARANCE (f) != ns_appearance_aqua) - win.appearance = [NSAppearance - appearanceNamed: NSAppearanceNameVibrantDark]; -#endif + [win setAppearance]; #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 if ([win respondsToSelector: @selector(titlebarAppearsTransparent)]) @@ -7558,6 +7627,17 @@ not_in_argv (NSString *arg) [NSApp registerServicesMenuSendTypes: ns_send_types returnTypes: [NSArray array]]; +#ifdef NS_DRAW_TO_BUFFER + [self createDrawingBuffer]; +#endif + + /* Set up view resize notifications. */ + [self setPostsFrameChangedNotifications:YES]; + [[NSNotificationCenter defaultCenter] + addObserver:self + selector:@selector (viewDidResize:) + name:NSViewFrameDidChangeNotification object:nil]; + /* macOS Sierra automatically enables tabbed windows. We can't allow this to be enabled until it's available on a Free system. Currently it only happens by accident and is buggy anyway. */ @@ -7587,15 +7667,15 @@ not_in_argv (NSString *arg) return; if (screen != nil) { - emacsframe->left_pos = r.origin.x - NS_PARENT_WINDOW_LEFT_POS (emacsframe); - emacsframe->top_pos = - NS_PARENT_WINDOW_TOP_POS (emacsframe) - (r.origin.y + r.size.height); + emacsframe->left_pos = NSMinX (r) - NS_PARENT_WINDOW_LEFT_POS (emacsframe); + emacsframe->top_pos = NS_PARENT_WINDOW_TOP_POS (emacsframe) - NSMaxY (r); - if (emacs_event) - { - emacs_event->kind = MOVE_FRAME_EVENT; - EV_TRAILER ((id)nil); - } + // FIXME: after event part below didExitFullScreen is not received + // if (emacs_event) + // { + // emacs_event->kind = MOVE_FRAME_EVENT; + // EV_TRAILER ((id)nil); + // } } } @@ -7795,6 +7875,7 @@ not_in_argv (NSString *arg) - (void)windowWillEnterFullScreen:(NSNotification *)notification { NSTRACE ("[EmacsView windowWillEnterFullScreen:]"); + in_fullscreen_transition = YES; [self windowWillEnterFullScreen]; } - (void)windowWillEnterFullScreen /* provided for direct calls */ @@ -7807,6 +7888,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidEnterFullScreen:]"); [self windowDidEnterFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidEnterFullScreen /* provided for direct calls */ @@ -7845,6 +7927,7 @@ not_in_argv (NSString *arg) - (void)windowWillExitFullScreen:(NSNotification *)notification { NSTRACE ("[EmacsView windowWillExitFullScreen:]"); + in_fullscreen_transition = YES; [self windowWillExitFullScreen]; } @@ -7864,6 +7947,7 @@ not_in_argv (NSString *arg) { NSTRACE ("[EmacsView windowDidExitFullScreen:]"); [self windowDidExitFullScreen]; + in_fullscreen_transition = NO; } - (void)windowDidExitFullScreen /* provided for direct calls */ @@ -7883,7 +7967,6 @@ not_in_argv (NSString *arg) { [toolbar setVisible:YES]; update_frame_tool_bar (emacsframe); - [self updateFrameSize:YES]; [[self window] display]; } else @@ -7893,6 +7976,22 @@ not_in_argv (NSString *arg) [[self window] performZoom:self]; } +- (BOOL)inFullScreenTransition +{ + return in_fullscreen_transition; +} + +- (void)waitFullScreenTransition +{ +#if MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 + while ([self inFullScreenTransition]) + { + NSTRACE ("wait for fullscreen"); + wait_reading_process_output (0, 300000000, 0, 1, Qnil, NULL, 0); + } +#endif +} + - (BOOL)fsIsNative { return fs_is_native; @@ -7931,9 +8030,22 @@ not_in_argv (NSString *arg) NSWindow *win = [self window]; NSWindowCollectionBehavior b = [win collectionBehavior]; if (ns_use_native_fullscreen) - b |= NSWindowCollectionBehaviorFullScreenPrimary; + { + if ([win parentWindow]) + { + b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + b |= NSWindowCollectionBehaviorFullScreenAuxiliary; + } + else + { + b |= NSWindowCollectionBehaviorFullScreenPrimary; + b &= ~NSWindowCollectionBehaviorFullScreenAuxiliary; + } + } else - b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + { + b &= ~NSWindowCollectionBehaviorFullScreenPrimary; + } [win setCollectionBehavior: b]; #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 @@ -7959,8 +8071,14 @@ not_in_argv (NSString *arg) #if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 1070 #if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 if ([[self window] respondsToSelector: @selector(toggleFullScreen:)]) + { +#endif + [[self window] toggleFullScreen:sender]; + // wait for fullscreen animation complete (bug#28496) + [self waitFullScreenTransition]; +#if MAC_OS_X_VERSION_MIN_REQUIRED < 1070 + } #endif - [[self window] toggleFullScreen:sender]; #endif return; } @@ -8061,11 +8179,11 @@ not_in_argv (NSString *arg) // send notifications. [self windowWillExitFullScreen]; - [fw setFrame: [w frame] display:YES animate:ns_use_fullscreen_animation]; + [fw setFrame:[[w contentView] frame] + display:YES animate:ns_use_fullscreen_animation]; [fw close]; [w makeKeyAndOrderFront:NSApp]; [self windowDidExitFullScreen]; - [self updateFrameSize:YES]; } } @@ -8209,13 +8327,8 @@ not_in_argv (NSString *arg) if (!emacs_event) return self; - /* Send first event (for some reason two needed). */ theEvent = [[self window] currentEvent]; emacs_event->kind = TOOL_BAR_EVENT; - XSETFRAME (emacs_event->arg, emacsframe); - EV_TRAILER (theEvent); - - emacs_event->kind = TOOL_BAR_EVENT; /* XSETINT (emacs_event->code, 0); */ emacs_event->arg = AREF (emacsframe->tool_bar_items, idx + TOOL_BAR_ITEM_KEY); @@ -8239,55 +8352,173 @@ not_in_argv (NSString *arg) } -- (void)viewWillDraw +#ifdef NS_DRAW_TO_BUFFER +- (void)createDrawingBuffer + /* Create and store a new CGGraphicsContext for Emacs to draw into. + + We can't do this in GNUstep as there's no equivalent, so under + GNUstep we retain the old method of drawing direct to the + EmacsView. */ { - /* If the frame has been garbaged there's no point in redrawing - anything. */ - if (FRAME_GARBAGED_P (emacsframe)) - [self setNeedsDisplay:NO]; + NSTRACE ("EmacsView createDrawingBuffer]"); + + if (! [self wantsUpdateLayer]) + return; + + NSGraphicsContext *screen; + CGColorSpaceRef colorSpace = [[[self window] colorSpace] CGColorSpace]; + CGFloat scale = [[self window] backingScaleFactor]; + NSRect frame = [self frame]; + + if (drawingBuffer != nil) + CGContextRelease (drawingBuffer); + + drawingBuffer = CGBitmapContextCreate (nil, NSWidth (frame) * scale, NSHeight (frame) * scale, + 8, 0, colorSpace, + kCGImageAlphaPremultipliedFirst | kCGBitmapByteOrder32Host); + + /* This fixes the scale to match the backing scale factor, and flips the image. */ + CGContextTranslateCTM(drawingBuffer, 0, NSHeight (frame) * scale); + CGContextScaleCTM(drawingBuffer, scale, -scale); } -- (void)drawRect: (NSRect)rect + +- (void)focusOnDrawingBuffer { - const NSRect *rectList; - NSInteger numRects; + NSTRACE ("EmacsView focusOnDrawingBuffer]"); - NSTRACE ("[EmacsView drawRect:" NSTRACE_FMT_RECT "]", - NSTRACE_ARG_RECT(rect)); + NSGraphicsContext *buf = + [NSGraphicsContext + graphicsContextWithCGContext:drawingBuffer flipped:YES]; - if (!emacsframe || !emacsframe->output_data.ns) + [NSGraphicsContext setCurrentContext:buf]; +} + + +- (void)windowDidChangeBackingProperties:(NSNotification *)notification + /* Update the drawing buffer when the backing scale factor changes. */ +{ + NSTRACE ("EmacsView windowDidChangeBackingProperties:]"); + + if (! [self wantsUpdateLayer]) return; - block_input (); + CGFloat old = [[[notification userInfo] + objectForKey:@"NSBackingPropertyOldScaleFactorKey"] + doubleValue]; + CGFloat new = [[self window] backingScaleFactor]; + + if (old != new) + { + NSRect frame = [self frame]; + [self createDrawingBuffer]; + ns_clear_frame (emacsframe); + expose_frame (emacsframe, 0, 0, NSWidth (frame), NSHeight (frame)); + } +} +#endif /* NS_DRAW_TO_BUFFER */ - /* Get only the precise dirty rectangles to avoid redrawing - potentially large areas of the frame that haven't changed. - I'm not sure this actually provides much of a performance benefit - as it's hard to benchmark, but it certainly doesn't seem to - hurt. */ - [self getRectsBeingDrawn:&rectList count:&numRects]; - for (int i = 0 ; i < numRects ; i++) +- (void)copyRect:(NSRect)srcRect to:(NSRect)dstRect +{ + NSTRACE ("[EmacsView copyRect:To:]"); + NSTRACE_RECT ("Source", srcRect); + NSTRACE_RECT ("Destination", dstRect); + +#ifdef NS_DRAW_TO_BUFFER +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if ([self wantsUpdateLayer]) { - NSRect r = rectList[i]; +#endif + CGImageRef copy; + NSRect frame = [self frame]; + NSAffineTransform *setOrigin = [NSAffineTransform transform]; + + [[NSGraphicsContext currentContext] saveGraphicsState]; + + /* Set the clipping before messing with the buffer's + orientation. */ + NSRectClip (dstRect); + + /* Unflip the buffer as the copied image will be unflipped, and + offset the top left so when we draw back into the buffer the + correct part of the image is drawn. */ + CGContextScaleCTM(drawingBuffer, 1, -1); + CGContextTranslateCTM(drawingBuffer, + NSMinX (dstRect) - NSMinX (srcRect), + -NSHeight (frame) - (NSMinY (dstRect) - NSMinY (srcRect))); + + /* Take a copy of the buffer and then draw it back to the buffer, + limited by the clipping rectangle. */ + copy = CGBitmapContextCreateImage (drawingBuffer); + CGContextDrawImage (drawingBuffer, frame, copy); - NSTRACE_RECT ("r", r); + CGImageRelease (copy); - expose_frame (emacsframe, - NSMinX (r), NSMinY (r), - NSWidth (r), NSHeight (r)); + [[NSGraphicsContext currentContext] restoreGraphicsState]; + [self setNeedsDisplayInRect:dstRect]; + +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 } + else + { +#endif +#endif /* NS_DRAW_TO_BUFFER */ - unblock_input (); +#if !defined (NS_DRAW_TO_BUFFER) || MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + hide_bell(); // Ensure the bell image isn't scrolled. + + ns_focus (emacsframe, &dstRect, 1); + [self scrollRect: srcRect + by: NSMakeSize (dstRect.origin.x - srcRect.origin.x, + dstRect.origin.y - srcRect.origin.y)]; + ns_unfocus (emacsframe); +#endif +#if defined (NS_DRAW_TO_BUFFER) && MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + } +#endif +} + + +#ifdef NS_DRAW_TO_BUFFER +- (BOOL)wantsUpdateLayer +{ +#if MAC_OS_X_VERSION_MIN_REQUIRED < 101400 + if (NSAppKitVersionNumber < 1671) + return NO; +#endif + + /* Running on macOS 10.14 or above. */ + return YES; +} - /* - drawRect: may be called (at least in Mac OS X 10.5) for invisible - views as well for some reason. Thus, do not infer visibility - here. - emacsframe->async_visible = 1; - emacsframe->async_iconified = 0; - */ +- (void)updateLayer +{ + NSTRACE ("[EmacsView updateLayer]"); + + CGImageRef contentsImage = CGBitmapContextCreateImage(drawingBuffer); + [[self layer] setContents:(id)contentsImage]; + CGImageRelease(contentsImage); +} +#endif + + +- (void)drawRect: (NSRect)rect +{ + NSTRACE ("[EmacsView drawRect:" NSTRACE_FMT_RECT "]", + NSTRACE_ARG_RECT(rect)); + + if (!emacsframe || !emacsframe->output_data.ns) + return; + + int x = NSMinX (rect), y = NSMinY (rect); + int width = NSWidth (rect), height = NSHeight (rect); + + ns_clear_frame_area (emacsframe, x, y, width, height); + block_input (); + expose_frame (emacsframe, x, y, width, height); + unblock_input (); } @@ -8488,13 +8719,6 @@ not_in_argv (NSString *arg) } -- (void) setRows: (int) r andColumns: (int) c -{ - NSTRACE ("[EmacsView setRows:%d andColumns:%d]", r, c); - rows = r; - cols = c; -} - - (int) fullscreenState { return fs_state; @@ -8748,6 +8972,32 @@ not_in_argv (NSString *arg) #endif } +- (void)setAppearance +{ +#if defined (NS_IMPL_COCOA) && MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 + struct frame *f = ((EmacsView *)[self delegate])->emacsframe; + NSAppearance *appearance = nil; + + NSTRACE ("[EmacsWindow setAppearance]"); + +#ifndef NSAppKitVersionNumber10_10 +#define NSAppKitVersionNumber10_10 1343 +#endif + + if (NSAppKitVersionNumber < NSAppKitVersionNumber10_10) + return; + + if (FRAME_NS_APPEARANCE (f) == ns_appearance_vibrant_dark) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameVibrantDark]; + else if (FRAME_NS_APPEARANCE (f) == ns_appearance_aqua) + appearance = + [NSAppearance appearanceNamed:NSAppearanceNameAqua]; + + [self setAppearance:appearance]; +#endif /* MAC_OS_X_VERSION_MAX_ALLOWED >= 101000 */ +} + - (void)setFrame:(NSRect)windowFrame display:(BOOL)displayViews { diff --git a/src/pdumper.c b/src/pdumper.c index 3ee11460405..7f6876666be 100644 --- a/src/pdumper.c +++ b/src/pdumper.c @@ -2239,7 +2239,7 @@ dump_bignum (struct dump_context *ctx, Lisp_Object object) static dump_off dump_float (struct dump_context *ctx, const struct Lisp_Float *lfloat) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_50A7B216D9) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Float_7E7D284C02) # error "Lisp_Float changed. See CHECK_STRUCTS comment in config.h." #endif eassert (ctx->header.cold_start); @@ -2603,7 +2603,7 @@ dump_vectorlike_generic (struct dump_context *ctx, Lisp_Object out; const Lisp_Object *vslot = &v->contents[i]; /* In the wide case, we're always misaligned. */ -#ifndef WIDE_EMACS_INT +#if INTPTR_MAX == EMACS_INT_MAX eassert (ctx->offset % sizeof (out) == 0); #endif dump_object_start (ctx, &out, sizeof (out)); @@ -2769,7 +2769,7 @@ dump_hash_table (struct dump_context *ctx, static dump_off dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) { -#if CHECK_STRUCTS && !defined HASH_buffer_375A10F5E5 +#if CHECK_STRUCTS && !defined HASH_buffer_5DC36DBD42 # error "buffer changed. See CHECK_STRUCTS comment in config.h." #endif struct buffer munged_buffer = *in_buffer; @@ -2845,8 +2845,6 @@ dump_buffer (struct dump_context *ctx, const struct buffer *in_buffer) ctx->obj_offset + dump_offsetof (struct buffer, text), base_offset + dump_offsetof (struct buffer, own_text)); - dump_field_lv_rawptr (ctx, out, buffer, &buffer->next, - Lisp_Vectorlike, WEIGHT_NORMAL); DUMP_FIELD_COPY (out, buffer, pt); DUMP_FIELD_COPY (out, buffer, pt_byte); DUMP_FIELD_COPY (out, buffer, begv); @@ -2961,7 +2959,7 @@ dump_vectorlike (struct dump_context *ctx, Lisp_Object lv, dump_off offset) { -#if CHECK_STRUCTS && !defined HASH_pvec_type_E55BD36F8E +#if CHECK_STRUCTS && !defined HASH_pvec_type_A4A6E9984D # error "pvec_type changed. See CHECK_STRUCTS comment in config.h." #endif const struct Lisp_Vector *v = XVECTOR (lv); @@ -3069,7 +3067,7 @@ dump_vectorlike (struct dump_context *ctx, static dump_off dump_object (struct dump_context *ctx, Lisp_Object object) { -#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_E2AD97D3F7) +#if CHECK_STRUCTS && !defined (HASH_Lisp_Type_45F0582FD7) # error "Lisp_Type changed. See CHECK_STRUCTS comment in config.h." #endif eassert (!EQ (object, dead_object ())); @@ -3604,14 +3602,12 @@ dump_unwind_cleanup (void *data) Vprocess_environment = ctx->old_process_environment; } -/* Return DUMP_OFFSET, making sure it is within the heap. */ -static dump_off +/* Check that DUMP_OFFSET is within the heap. */ +static void dump_check_dump_off (struct dump_context *ctx, dump_off dump_offset) { eassert (dump_offset > 0); - if (ctx) - eassert (dump_offset < ctx->end_heap); - return dump_offset; + eassert (!ctx || dump_offset < ctx->end_heap); } static void @@ -3734,6 +3730,7 @@ decode_emacs_reloc (struct dump_context *ctx, Lisp_Object lreloc) } else { + eassume (ctx); /* Pacify GCC 9.2.1 -O3 -Wnull-dereference. */ eassert (!dump_object_emacs_ptr (target_value)); reloc.u.dump_offset = dump_recall_object (ctx, target_value); if (reloc.u.dump_offset <= 0) diff --git a/src/print.c b/src/print.c index 425b0dc4ee3..bd1769144e0 100644 --- a/src/print.c +++ b/src/print.c @@ -368,8 +368,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, int len; for (ptrdiff_t i = 0; i < size_byte; i += len) { - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int ch = string_char_and_length ((const unsigned char *) ptr + i, + &len); printchar_to_stream (ch, stdout); } } @@ -400,8 +400,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, int len; for (i = 0; i < size_byte; i += len) { - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int ch = string_char_and_length ((const unsigned char *) ptr + i, + &len); insert_char (ch); } } @@ -426,9 +426,8 @@ strout (const char *ptr, ptrdiff_t size, ptrdiff_t size_byte, /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int len; - int ch = STRING_CHAR_AND_LENGTH ((const unsigned char *) ptr + i, - len); + int len, ch = (string_char_and_length + ((const unsigned char *) ptr + i, &len)); printchar (ch, printcharfun); i += len; } @@ -510,8 +509,7 @@ print_string (Lisp_Object string, Lisp_Object printcharfun) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int len; - int ch = STRING_CHAR_AND_LENGTH (SDATA (string) + i, len); + int len, ch = string_char_and_length (SDATA (string) + i, &len); printchar (ch, printcharfun); i += len; } @@ -1307,15 +1305,13 @@ print_check_string_charset_prop (INTERVAL interval, Lisp_Object string) } if (! (print_check_string_result & PRINT_STRING_UNSAFE_CHARSET_FOUND)) { - int i, c; ptrdiff_t charpos = interval->position; ptrdiff_t bytepos = string_char_to_byte (string, charpos); - Lisp_Object charset; + Lisp_Object charset = XCAR (XCDR (val)); - charset = XCAR (XCDR (val)); - for (i = 0; i < LENGTH (interval); i++) + for (ptrdiff_t i = 0; i < LENGTH (interval); i++) { - FETCH_STRING_CHAR_ADVANCE (c, string, charpos, bytepos); + int c = fetch_string_char_advance (string, &charpos, &bytepos); if (! ASCII_CHAR_P (c) && ! EQ (CHARSET_NAME (CHAR_CHARSET (c)), charset)) { @@ -1365,6 +1361,22 @@ data_from_funcptr (void (*funcptr) (void)) interchangeably, so it's OK to assume that here too. */ return (void const *) funcptr; } + +/* Print the value of the pointer PTR. */ + +static void +print_pointer (Lisp_Object printcharfun, char *buf, const char *prefix, + const void *ptr) +{ + uintptr_t ui = (uintptr_t) ptr; + + /* In theory this assignment could lose info on pre-C99 hosts, but + in practice it doesn't. */ + uintmax_t up = ui; + + int len = sprintf (buf, "%s 0x%" PRIxMAX, prefix, up); + strout (buf, len, len, printcharfun); +} #endif static bool @@ -1796,26 +1808,22 @@ print_vectorlike (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag, case PVEC_MODULE_FUNCTION: { print_c_string ("#<module function ", printcharfun); - module_funcptr ptr = module_function_address (XMODULE_FUNCTION (obj)); + const struct Lisp_Module_Function *function = XMODULE_FUNCTION (obj); + module_funcptr ptr = module_function_address (function); char const *file; char const *symbol; dynlib_addr (ptr, &file, &symbol); if (symbol == NULL) - { - uintptr_t ui = (uintptr_t) data_from_funcptr (ptr); - - /* In theory this assignment could lose info on pre-C99 - hosts, but in practice it doesn't. */ - uintmax_t up = ui; - - int len = sprintf (buf, "at 0x%"PRIxMAX, up); - strout (buf, len, len, printcharfun); - } - else + print_pointer (printcharfun, buf, "at", data_from_funcptr (ptr)); + else print_c_string (symbol, printcharfun); - if (file != NULL) + void *data = module_function_data (function); + if (data != NULL) + print_pointer (printcharfun, buf, " with data", data); + + if (file != NULL) { print_c_string (" from ", printcharfun); print_c_string (file, printcharfun); @@ -1838,7 +1846,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { char buf[max (sizeof "from..to..in " + 2 * INT_STRLEN_BOUND (EMACS_INT), max (sizeof " . #" + INT_STRLEN_BOUND (intmax_t), - max ((sizeof "at 0x" + max ((sizeof " with data 0x" + (sizeof (uintmax_t) * CHAR_BIT + 4 - 1) / 4), 40)))]; current_thread->stack_top = buf; @@ -1931,9 +1939,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to printchar. */ - int c; - - FETCH_STRING_CHAR_ADVANCE (c, obj, i, i_byte); + int c = fetch_string_char_advance (obj, &i, &i_byte); maybe_quit (); @@ -2024,8 +2030,7 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) { /* Here, we must convert each multi-byte form to the corresponding character code before handing it to PRINTCHAR. */ - int c; - FETCH_STRING_CHAR_ADVANCE (c, name, i, i_byte); + int c = fetch_string_char_advance (name, &i, &i_byte); maybe_quit (); if (escapeflag) diff --git a/src/process.c b/src/process.c index 91d426103d8..6e5bcf307ab 100644 --- a/src/process.c +++ b/src/process.c @@ -1392,14 +1392,12 @@ nil otherwise. */) CHECK_PROCESS (process); /* All known platforms store window sizes as 'unsigned short'. */ - CHECK_RANGED_INTEGER (height, 0, USHRT_MAX); - CHECK_RANGED_INTEGER (width, 0, USHRT_MAX); + unsigned short h = check_uinteger_max (height, USHRT_MAX); + unsigned short w = check_uinteger_max (width, USHRT_MAX); if (NETCONN_P (process) || XPROCESS (process)->infd < 0 - || (set_window_size (XPROCESS (process)->infd, - XFIXNUM (height), XFIXNUM (width)) - < 0)) + || set_window_size (XPROCESS (process)->infd, h, w) < 0) return Qnil; else return Qt; @@ -3188,14 +3186,12 @@ usage: (make-serial-process &rest ARGS) */) BUF_ZV_BYTE (XBUFFER (buffer))); } - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; + tem = Fplist_get (contact, QCcoding); val = Qnil; if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCAR (val); } @@ -3209,7 +3205,7 @@ usage: (make-serial-process &rest ARGS) */) val = Qnil; if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCDR (val); } @@ -3244,16 +3240,14 @@ set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, Lisp_Object coding_systems = Qt; Lisp_Object val; - tem = Fplist_member (contact, QCcoding); - if (!NILP (tem) && (!CONSP (tem) || !CONSP (XCDR (tem)))) - tem = Qnil; /* No error message (too late!). */ + tem = Fplist_get (contact, QCcoding); /* Setup coding systems for communicating with the network stream. */ /* Qt denotes we have not yet called Ffind_operation_coding_system. */ if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCAR (val); } @@ -3287,7 +3281,7 @@ set_network_socket_coding_system (Lisp_Object proc, Lisp_Object host, if (!NILP (tem)) { - val = XCAR (XCDR (tem)); + val = tem; if (CONSP (val)) val = XCDR (val); } @@ -7079,10 +7073,7 @@ SIGCODE may be an integer, or a symbol whose name is a signal name. */) } if (FIXNUMP (sigcode)) - { - CHECK_TYPE_RANGED_INTEGER (int, sigcode); - signo = XFIXNUM (sigcode); - } + signo = check_integer_range (sigcode, INT_MIN, INT_MAX); else { char *name; @@ -8200,6 +8191,17 @@ restore_nofile_limit (void) #endif } +int +open_channel_for_module (Lisp_Object process) +{ + CHECK_PROCESS (process); + CHECK_TYPE (PIPECONN_P (process), Qpipe_process_p, process); + int fd = dup (XPROCESS (process)->open_fd[SUBPROCESS_STDOUT]); + if (fd == -1) + report_file_error ("Cannot duplicate file descriptor", Qnil); + return fd; +} + /* This is not called "init_process" because that is the name of a Mach system call, so it would cause problems on Darwin systems. */ @@ -8277,19 +8279,6 @@ init_process_emacs (int sockfd) memset (datagram_address, 0, sizeof datagram_address); #endif -#if defined (DARWIN_OS) - /* PTYs are broken on Darwin < 6, but are sometimes useful for interactive - processes. As such, we only change the default value. */ - if (initialized) - { - char const *release = (STRINGP (Voperating_system_release) - ? SSDATA (Voperating_system_release) - : 0); - if (!release || !release[0] || (release[0] < '7' && release[1] == '.')) { - Vprocess_connection_type = Qnil; - } - } -#endif #endif /* subprocesses */ kbd_is_on_hold = 0; } @@ -8459,6 +8448,7 @@ amounts of data in one go. */); DEFSYM (Qinterrupt_process_functions, "interrupt-process-functions"); DEFSYM (Qnull, "null"); + DEFSYM (Qpipe_process_p, "pipe-process-p"); defsubr (&Sprocessp); defsubr (&Sget_process); diff --git a/src/process.h b/src/process.h index 7884efc5494..a783a31cb86 100644 --- a/src/process.h +++ b/src/process.h @@ -300,6 +300,8 @@ extern Lisp_Object remove_slash_colon (Lisp_Object); extern void update_processes_for_thread_death (Lisp_Object); extern void dissociate_controlling_tty (void); +extern int open_channel_for_module (Lisp_Object); + INLINE_HEADER_END #endif /* EMACS_PROCESS_H */ diff --git a/src/regex-emacs.c b/src/regex-emacs.c index 5e23fc94e4f..ba7f3cef64b 100644 --- a/src/regex-emacs.c +++ b/src/regex-emacs.c @@ -58,7 +58,7 @@ #define RE_STRING_CHAR(p, multibyte) \ (multibyte ? STRING_CHAR (p) : *(p)) #define RE_STRING_CHAR_AND_LENGTH(p, len, multibyte) \ - (multibyte ? STRING_CHAR_AND_LENGTH (p, len) : ((len) = 1, *(p))) + (multibyte ? string_char_and_length (p, &(len)) : ((len) = 1, *(p))) #define RE_CHAR_TO_MULTIBYTE(c) UNIBYTE_TO_CHAR (c) @@ -89,7 +89,7 @@ #define GET_CHAR_AFTER(c, p, len) \ do { \ if (target_multibyte) \ - (c) = STRING_CHAR_AND_LENGTH (p, len); \ + (c) = string_char_and_length (p, &(len)); \ else \ { \ (c) = *p; \ @@ -2113,17 +2113,20 @@ regex_compile (re_char *pattern, ptrdiff_t size, if (CHAR_BYTE8_P (c1)) c = BYTE8_TO_CHAR (128); } - if (CHAR_BYTE8_P (c)) - { - c = CHAR_TO_BYTE8 (c); - c1 = CHAR_TO_BYTE8 (c1); - for (; c <= c1; c++) - SET_LIST_BIT (c); - } - else if (multibyte) - SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); - else - SETUP_UNIBYTE_RANGE (range_table_work, c, c1); + if (c <= c1) + { + if (CHAR_BYTE8_P (c)) + { + c = CHAR_TO_BYTE8 (c); + c1 = CHAR_TO_BYTE8 (c1); + for (; c <= c1; c++) + SET_LIST_BIT (c); + } + else if (multibyte) + SETUP_MULTIBYTE_RANGE (range_table_work, c, c1); + else + SETUP_UNIBYTE_RANGE (range_table_work, c, c1); + } } } @@ -3164,10 +3167,6 @@ re_search (struct re_pattern_buffer *bufp, const char *string, ptrdiff_t size, regs, size); } -/* Head address of virtual concatenation of string. */ -#define HEAD_ADDR_VSTRING(P) \ - (((P) >= size1 ? string2 : string1)) - /* Address of POS in the concatenation of virtual string. */ #define POS_ADDR_VSTRING(POS) \ (((POS) >= size1 ? string2 - size1 : string1) + (POS)) @@ -3297,7 +3296,7 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, { int buf_charlen; - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); buf_ch = RE_TRANSLATE (translate, buf_ch); if (fastmap[CHAR_LEADING_CODE (buf_ch)]) break; @@ -3327,7 +3326,7 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, { int buf_charlen; - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); if (fastmap[CHAR_LEADING_CODE (buf_ch)]) break; range -= buf_charlen; @@ -3410,16 +3409,12 @@ re_search_2 (struct re_pattern_buffer *bufp, const char *str1, ptrdiff_t size1, if (multibyte) { re_char *p = POS_ADDR_VSTRING (startpos) + 1; - re_char *p0 = p; - re_char *phead = HEAD_ADDR_VSTRING (startpos); + int len = raw_prev_char_len (p); - /* Find the head of multibyte form. */ - PREV_CHAR_BOUNDARY (p, phead); - range += p0 - 1 - p; + range += len - 1; if (range > 0) break; - - startpos -= p0 - 1 - p; + startpos -= len - 1; } } } @@ -4238,13 +4233,13 @@ re_match_2_internal (struct re_pattern_buffer *bufp, PREFETCH (); if (multibyte) - pat_ch = STRING_CHAR_AND_LENGTH (p, pat_charlen); + pat_ch = string_char_and_length (p, &pat_charlen); else { pat_ch = RE_CHAR_TO_MULTIBYTE (*p); pat_charlen = 1; } - buf_ch = STRING_CHAR_AND_LENGTH (d, buf_charlen); + buf_ch = string_char_and_length (d, &buf_charlen); if (TRANSLATE (buf_ch) != pat_ch) { @@ -4266,7 +4261,7 @@ re_match_2_internal (struct re_pattern_buffer *bufp, PREFETCH (); if (multibyte) { - pat_ch = STRING_CHAR_AND_LENGTH (p, pat_charlen); + pat_ch = string_char_and_length (p, &pat_charlen); pat_ch = RE_CHAR_TO_UNIBYTE (pat_ch); } else diff --git a/src/search.c b/src/search.c index 818bb4af246..ec076c18035 100644 --- a/src/search.c +++ b/src/search.c @@ -353,8 +353,8 @@ data if you want to preserve them. */) } DEFUN ("posix-looking-at", Fposix_looking_at, Sposix_looking_at, 1, 1, 0, - doc: /* Return t if text after point matches regular expression REGEXP. -Find the longest match, in accord with Posix regular expression rules. + doc: /* Return t if text after point matches REGEXP according to Posix rules. +Find the longest match, in accordance with Posix regular expression rules. This function modifies the match data that `match-beginning', `match-end' and `match-data' access; save and restore the match data if you want to preserve them. */) @@ -449,7 +449,7 @@ matched by the parenthesis constructions in REGEXP. */) } DEFUN ("posix-string-match", Fposix_string_match, Sposix_string_match, 2, 3, 0, - doc: /* Return index of start of first match for REGEXP in STRING, or nil. + doc: /* Return index of start of first match for Posix REGEXP in STRING, or nil. Find the longest match, in accord with Posix regular expression rules. Case is ignored if `case-fold-search' is non-nil in the current buffer. If third arg START is non-nil, start search at that index in STRING. @@ -994,7 +994,7 @@ find_before_next_newline (ptrdiff_t from, ptrdiff_t to, if (counted == cnt) { if (bytepos) - DEC_BOTH (pos, *bytepos); + dec_both (&pos, &*bytepos); else pos--; } @@ -1028,8 +1028,7 @@ search_command (Lisp_Object string, Lisp_Object bound, Lisp_Object noerror, } else { - CHECK_FIXNUM_COERCE_MARKER (bound); - lim = XFIXNUM (bound); + lim = fix_position (bound); if (n > 0 ? lim < PT : lim > PT) error ("Invalid search bound (wrong side of point)"); if (lim > ZV) @@ -1354,8 +1353,8 @@ search_buffer_non_re (Lisp_Object string, ptrdiff_t pos, while (--len >= 0) { unsigned char str_base[MAX_MULTIBYTE_LENGTH], *str; - int c, translated, inverse; - int in_charlen, charlen; + int translated, inverse; + int charlen; /* If we got here and the RE flag is set, it's because we're dealing with a regexp known to be trivial, so the backslash @@ -1368,7 +1367,7 @@ search_buffer_non_re (Lisp_Object string, ptrdiff_t pos, base_pat++; } - c = STRING_CHAR_AND_LENGTH (base_pat, in_charlen); + int in_charlen, c = string_char_and_length (base_pat, &in_charlen); if (NILP (trt)) { @@ -1551,12 +1550,10 @@ simple_search (EMACS_INT n, unsigned char *pat, while (this_len > 0) { - int charlen, buf_charlen; - int pat_ch, buf_ch; - - pat_ch = STRING_CHAR_AND_LENGTH (p, charlen); - buf_ch = STRING_CHAR_AND_LENGTH (BYTE_POS_ADDR (this_pos_byte), - buf_charlen); + int charlen, pat_ch = string_char_and_length (p, &charlen); + int buf_charlen, buf_ch + = string_char_and_length (BYTE_POS_ADDR (this_pos_byte), + &buf_charlen); TRANSLATE (buf_ch, trt, buf_ch); if (buf_ch != pat_ch) @@ -1577,7 +1574,7 @@ simple_search (EMACS_INT n, unsigned char *pat, break; } - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); } n--; @@ -1639,8 +1636,8 @@ simple_search (EMACS_INT n, unsigned char *pat, { int pat_ch, buf_ch; - DEC_BOTH (this_pos, this_pos_byte); - PREV_CHAR_BOUNDARY (p, pat); + dec_both (&this_pos, &this_pos_byte); + p -= raw_prev_char_len (p); pat_ch = STRING_CHAR (p); buf_ch = STRING_CHAR (BYTE_POS_ADDR (this_pos_byte)); TRANSLATE (buf_ch, trt, buf_ch); @@ -1659,7 +1656,7 @@ simple_search (EMACS_INT n, unsigned char *pat, break; } - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); } n++; @@ -2279,7 +2276,7 @@ and `replace-match'. */) DEFUN ("posix-search-backward", Fposix_search_backward, Sposix_search_backward, 1, 4, "sPosix search backward: ", - doc: /* Search backward from point for match for regular expression REGEXP. + doc: /* Search backward from point for match for REGEXP according to Posix rules. Find the longest match in accord with Posix regular expression rules. Set point to the beginning of the occurrence found, and return point. An optional second argument bounds the search; it is a buffer position. @@ -2307,7 +2304,7 @@ and `replace-match'. */) DEFUN ("posix-search-forward", Fposix_search_forward, Sposix_search_forward, 1, 4, "sPosix search: ", - doc: /* Search forward from point for regular expression REGEXP. + doc: /* Search forward from point for REGEXP according to Posix rules. Find the longest match in accord with Posix regular expression rules. Set point to the end of the occurrence found, and return point. An optional second argument bounds the search; it is a buffer position. @@ -2393,14 +2390,7 @@ since only regular expressions have distinguished subexpressions. */) if (num_regs <= 0) error ("`replace-match' called before any match found"); - if (NILP (subexp)) - sub = 0; - else - { - CHECK_RANGED_INTEGER (subexp, 0, num_regs - 1); - sub = XFIXNUM (subexp); - } - + sub = !NILP (subexp) ? check_integer_range (subexp, 0, num_regs - 1) : 0; ptrdiff_t sub_start = search_regs.start[sub]; ptrdiff_t sub_end = search_regs.end[sub]; eassert (sub_start <= sub_end); @@ -2445,10 +2435,11 @@ since only regular expressions have distinguished subexpressions. */) if (NILP (string)) { c = FETCH_CHAR_AS_MULTIBYTE (pos_byte); - INC_BOTH (pos, pos_byte); + inc_both (&pos, &pos_byte); } else - FETCH_STRING_CHAR_AS_MULTIBYTE_ADVANCE (c, string, pos, pos_byte); + c = fetch_string_char_as_multibyte_advance (string, + &pos, &pos_byte); if (lowercasep (c)) { @@ -2521,11 +2512,11 @@ since only regular expressions have distinguished subexpressions. */) ptrdiff_t subend = 0; bool delbackslash = 0; - FETCH_STRING_CHAR_ADVANCE (c, newtext, pos, pos_byte); + c = fetch_string_char_advance (newtext, &pos, &pos_byte); if (c == '\\') { - FETCH_STRING_CHAR_ADVANCE (c, newtext, pos, pos_byte); + c = fetch_string_char_advance (newtext, &pos, &pos_byte); if (c == '&') { @@ -2633,7 +2624,8 @@ since only regular expressions have distinguished subexpressions. */) if (str_multibyte) { - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, newtext, pos, pos_byte); + c = fetch_string_char_advance_no_check (newtext, + &pos, &pos_byte); if (!buf_multibyte) c = CHAR_TO_BYTE8 (c); } @@ -2642,7 +2634,7 @@ since only regular expressions have distinguished subexpressions. */) /* Note that we don't have to increment POS. */ c = SREF (newtext, pos_byte++); if (buf_multibyte) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); } /* Either set ADD_STUFF and ADD_LEN to the text to put in SUBSTED, @@ -2655,8 +2647,8 @@ since only regular expressions have distinguished subexpressions. */) if (str_multibyte) { - FETCH_STRING_CHAR_ADVANCE_NO_CHECK (c, newtext, - pos, pos_byte); + c = fetch_string_char_advance_no_check (newtext, + &pos, &pos_byte); if (!buf_multibyte && !ASCII_CHAR_P (c)) c = CHAR_TO_BYTE8 (c); } @@ -2664,7 +2656,7 @@ since only regular expressions have distinguished subexpressions. */) { c = SREF (newtext, pos_byte++); if (buf_multibyte) - MAKE_CHAR_MULTIBYTE (c); + c = make_char_multibyte (c); } if (c == '&') diff --git a/src/syntax.c b/src/syntax.c index a79ab863367..a03202d386c 100644 --- a/src/syntax.c +++ b/src/syntax.c @@ -535,7 +535,7 @@ char_quoted (ptrdiff_t charpos, ptrdiff_t bytepos) while (charpos > beg) { int c; - DEC_BOTH (charpos, bytepos); + dec_both (&charpos, &bytepos); UPDATE_SYNTAX_TABLE_BACKWARD (charpos); c = FETCH_CHAR_AS_MULTIBYTE (bytepos); @@ -556,11 +556,9 @@ char_quoted (ptrdiff_t charpos, ptrdiff_t bytepos) static ptrdiff_t dec_bytepos (ptrdiff_t bytepos) { - if (NILP (BVAR (current_buffer, enable_multibyte_characters))) - return bytepos - 1; - - DEC_POS (bytepos); - return bytepos; + return (bytepos + - (!NILP (BVAR (current_buffer, enable_multibyte_characters)) + ? prev_char_len (bytepos) : 1)); } /* Return a defun-start position before POS and not too far before. @@ -667,7 +665,7 @@ prev_char_comend_first (ptrdiff_t pos, ptrdiff_t pos_byte) int c; bool val; - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); UPDATE_SYNTAX_TABLE_BACKWARD (pos); c = FETCH_CHAR (pos_byte); val = SYNTAX_COMEND_FIRST (c); @@ -738,7 +736,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, bool com2start, com2end, comstart; /* Move back and examine a character. */ - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); prev_syntax = syntax; @@ -773,7 +771,7 @@ back_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, { ptrdiff_t next = from, next_byte = from_byte; int next_c, next_syntax; - DEC_BOTH (next, next_byte); + dec_both (&next, &next_byte); UPDATE_SYNTAX_TABLE_BACKWARD (next); next_c = FETCH_CHAR_AS_MULTIBYTE (next_byte); next_syntax = SYNTAX_WITH_FLAGS (next_c); @@ -1150,8 +1148,7 @@ the value of a `syntax-table' text property. */) if (*p) { - int len; - int character = STRING_CHAR_AND_LENGTH (p, len); + int len, character = string_char_and_length (p, &len); XSETINT (match, character); if (XFIXNAT (match) == ' ') match = Qnil; @@ -1444,7 +1441,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) int ch0, ch1; Lisp_Object func, pos; - SETUP_SYNTAX_TABLE (from, count); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count, PTRDIFF_MAX)); while (count > 0) { @@ -1455,7 +1452,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) UPDATE_SYNTAX_TABLE_FORWARD (from); ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch0); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (words_include_escapes && (code == Sescape || code == Scharquote)) break; @@ -1488,7 +1485,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) || (code != Sescape && code != Scharquote))) || word_boundary_p (ch0, ch1)) break; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); ch0 = ch1; rarely_quit (from); } @@ -1501,7 +1498,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) { if (from == beg) return 0; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); ch1 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch1); @@ -1530,7 +1527,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) { if (from == beg) break; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); ch0 = FETCH_CHAR_AS_MULTIBYTE (from_byte); code = SYNTAX (ch0); @@ -1539,7 +1536,7 @@ scan_words (ptrdiff_t from, EMACS_INT count) || (code != Sescape && code != Scharquote))) || word_boundary_p (ch0, ch1)) { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); break; } ch1 = ch0; @@ -1818,7 +1815,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, leading_code = str[i_byte]; } - c = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c = string_char_and_length (str + i_byte, &len); i_byte += len; @@ -1834,14 +1831,14 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, /* Get the end of the range. */ leading_code2 = str[i_byte]; - c2 = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c2 = string_char_and_length (str + i_byte, &len); i_byte += len; if (c2 == '\\' && i_byte < size_byte) { leading_code2 = str[i_byte]; - c2 = STRING_CHAR_AND_LENGTH (str + i_byte, len); + c2 = string_char_and_length (str + i_byte, &len); i_byte += len; } @@ -1953,7 +1950,7 @@ skip_chars (bool forwardp, Lisp_Object string, Lisp_Object lim, p = GAP_END_ADDR; stop = endp; } - c = STRING_CHAR_AND_LENGTH (p, nbytes); + c = string_char_and_length (p, &nbytes); if (! NILP (iso_classes) && in_classes (c, iso_classes)) { if (negate) @@ -2175,7 +2172,7 @@ skip_syntaxes (bool forwardp, Lisp_Object string, Lisp_Object lim) stop = endp; } if (multibyte) - c = STRING_CHAR_AND_LENGTH (p, nbytes); + c = string_char_and_length (p, &nbytes); else c = *p, nbytes = 1; if (! fastmap[SYNTAX (c)]) @@ -2357,7 +2354,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, /* We have encountered a nested comment of the same style as the comment sequence which began this comment section. */ nesting++; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); forw_incomment: @@ -2378,7 +2375,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, break; else { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } } @@ -2395,7 +2392,7 @@ forw_comment (ptrdiff_t from, ptrdiff_t from_byte, ptrdiff_t stop, as the comment sequence which began this comment section. */ { syntax = Smax; /* So that "#|#" isn't also a comment ender. */ - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); nesting++; } @@ -2437,7 +2434,7 @@ between them, return t; otherwise return nil. */) from = PT; from_byte = PT_BYTE; - SETUP_SYNTAX_TABLE (from, count1); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count1, PTRDIFF_MAX)); while (count1 > 0) { do @@ -2456,7 +2453,7 @@ between them, return t; otherwise return nil. */) comstart_first = SYNTAX_FLAGS_COMSTART_FIRST (syntax); comnested = SYNTAX_FLAGS_COMMENT_NESTED (syntax); comstyle = SYNTAX_FLAGS_COMMENT_STYLE (syntax, 0); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); if (from < stop && comstart_first && (c1 = FETCH_CHAR_AS_MULTIBYTE (from_byte), @@ -2471,7 +2468,7 @@ between them, return t; otherwise return nil. */) code = Scomment; comstyle = SYNTAX_FLAGS_COMMENT_STYLE (other_syntax, syntax); comnested |= SYNTAX_FLAGS_COMMENT_NESTED (other_syntax); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } rarely_quit (++quit_count); @@ -2482,7 +2479,7 @@ between them, return t; otherwise return nil. */) comstyle = ST_COMMENT_STYLE; else if (code != Scomment) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); SET_PT_BOTH (from, from_byte); return Qnil; } @@ -2495,7 +2492,7 @@ between them, return t; otherwise return nil. */) SET_PT_BOTH (from, from_byte); return Qnil; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); /* We have skipped one comment. */ count1--; @@ -2511,7 +2508,7 @@ between them, return t; otherwise return nil. */) return Qnil; } - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); /* char_quoted does UPDATE_SYNTAX_TABLE_BACKWARD (from). */ bool quoted = char_quoted (from, from_byte); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2529,7 +2526,7 @@ between them, return t; otherwise return nil. */) /* We must record the comment style encountered so that later, we can match only the proper comment begin sequence of the same style. */ - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); code = Sendcomment; /* Calling char_quoted, above, set up global syntax position at the new value of FROM. */ @@ -2547,7 +2544,7 @@ between them, return t; otherwise return nil. */) while (1) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); if (SYNTAX (c) == Scomment_fence @@ -2572,8 +2569,9 @@ between them, return t; otherwise return nil. */) } else if (code == Sendcomment) { - found = back_comment (from, from_byte, stop, comnested, comstyle, - &out_charpos, &out_bytepos); + found = (!quoted || !Vcomment_end_can_be_escaped) + && back_comment (from, from_byte, stop, comnested, comstyle, + &out_charpos, &out_bytepos); if (!found) { if (c == '\n') @@ -2587,7 +2585,7 @@ between them, return t; otherwise return nil. */) not-quite-endcomment. */ if (SYNTAX (c) != code) /* It was a two-char Sendcomment. */ - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); goto leave; } } @@ -2601,7 +2599,7 @@ between them, return t; otherwise return nil. */) else if (code != Swhitespace || quoted) { leave: - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); SET_PT_BOTH (from, from_byte); return Qnil; } @@ -2626,7 +2624,7 @@ syntax_multibyte (int c, bool multibyte_symbol_p) } static Lisp_Object -scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) +scan_lists (EMACS_INT from0, EMACS_INT count, EMACS_INT depth, bool sexpflag) { Lisp_Object val; ptrdiff_t stop = count > 0 ? ZV : BEGV; @@ -2639,7 +2637,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) int comstyle = 0; /* Style of comment encountered. */ bool comnested = 0; /* Whether the comment is nestable or not. */ ptrdiff_t temp_pos; - EMACS_INT last_good = from; + EMACS_INT last_good = from0; bool found; ptrdiff_t from_byte; ptrdiff_t out_bytepos, out_charpos; @@ -2650,14 +2648,13 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if (depth > 0) min_depth = 0; - if (from > ZV) from = ZV; - if (from < BEGV) from = BEGV; + ptrdiff_t from = clip_to_bounds (BEGV, from0, ZV); from_byte = CHAR_TO_BYTE (from); maybe_quit (); - SETUP_SYNTAX_TABLE (from, count); + SETUP_SYNTAX_TABLE (from, clip_to_bounds (PTRDIFF_MIN, count, PTRDIFF_MAX)); while (count > 0) { while (from < stop) @@ -2675,7 +2672,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) prefix = SYNTAX_FLAGS_PREFIX (syntax); if (depth == min_depth) last_good = from; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); if (from < stop && comstart_first && (c = FETCH_CHAR_AS_MULTIBYTE (from_byte), @@ -2691,7 +2688,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) code = Scomment; comstyle = SYNTAX_FLAGS_COMMENT_STYLE (other_syntax, syntax); comnested |= SYNTAX_FLAGS_COMMENT_NESTED (other_syntax); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); } @@ -2704,7 +2701,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) case Scharquote: if (from == stop) goto lose; - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); /* Treat following character as a word constituent. */ FALLTHROUGH; case Sword: @@ -2720,7 +2717,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { case Scharquote: case Sescape: - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (from == stop) goto lose; break; @@ -2731,7 +2728,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) default: goto done; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); rarely_quit (++quit_count); } goto done; @@ -2753,7 +2750,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) goto done; goto lose; } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_FORWARD (from); break; @@ -2762,7 +2759,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) break; if (from != stop && c == FETCH_CHAR_AS_MULTIBYTE (from_byte)) { - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); } if (mathexit) { @@ -2802,11 +2799,11 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) break; if (c_code == Scharquote || c_code == Sescape) - INC_BOTH (from, from_byte); - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); + inc_both (&from, &from_byte); rarely_quit (++quit_count); } - INC_BOTH (from, from_byte); + inc_both (&from, &from_byte); if (!depth && sexpflag) goto done; break; default: @@ -2831,7 +2828,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) while (from > stop) { rarely_quit (++quit_count); - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); c = FETCH_CHAR_AS_MULTIBYTE (from_byte); int syntax = SYNTAX_WITH_FLAGS (c); @@ -2850,7 +2847,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) later, we can match only the proper comment begin sequence of the same style. */ int c2, other_syntax; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); code = Sendcomment; c2 = FETCH_CHAR_AS_MULTIBYTE (from_byte); @@ -2864,7 +2861,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) if we decremented FROM in the if-statement above. */ if (code != Sendcomment && char_quoted (from, from_byte)) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); code = Sword; } else if (SYNTAX_FLAGS_PREFIX (syntax)) @@ -2881,11 +2878,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) after passing it. */ while (from > stop) { - temp_pos = from_byte; - if (! NILP (BVAR (current_buffer, enable_multibyte_characters))) - DEC_POS (temp_pos); - else - temp_pos--; + temp_pos = dec_bytepos (from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); c1 = FETCH_CHAR_AS_MULTIBYTE (temp_pos); /* Don't allow comment-end to be quoted. */ @@ -2894,7 +2887,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) quoted = char_quoted (from - 1, temp_pos); if (quoted) { - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); temp_pos = dec_bytepos (temp_pos); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); } @@ -2905,7 +2898,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) case Sword: case Ssymbol: case Squote: break; default: goto done2; } - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); rarely_quit (++quit_count); } goto done2; @@ -2918,7 +2911,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) temp_pos = dec_bytepos (from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from - 1); if (from != stop && c == FETCH_CHAR_AS_MULTIBYTE (temp_pos)) - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); } if (mathexit) { @@ -2961,7 +2954,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { if (from == stop) goto lose; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); if (!char_quoted (from, from_byte)) { @@ -2980,7 +2973,7 @@ scan_lists (EMACS_INT from, EMACS_INT count, EMACS_INT depth, bool sexpflag) { if (from == stop) goto lose; - DEC_BOTH (from, from_byte); + dec_both (&from, &from_byte); UPDATE_SYNTAX_TABLE_BACKWARD (from); if (!char_quoted (from, from_byte)) { @@ -3090,7 +3083,7 @@ the prefix syntax flag (p). */) SETUP_SYNTAX_TABLE (pos, -1); - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); while (!char_quoted (pos, pos_byte) /* Previous statement updates syntax table. */ @@ -3102,7 +3095,7 @@ the prefix syntax flag (p). */) if (pos <= beg) break; - DEC_BOTH (pos, pos_byte); + dec_both (&pos, &pos_byte); rarely_quit (pos); } @@ -3179,7 +3172,7 @@ scan_sexps_forward (struct lisp_parse_state *state, prev_from = from; prev_from_byte = from_byte; if (from != BEGV) - DEC_BOTH (prev_from, prev_from_byte); + dec_both (&prev_from, &prev_from_byte); /* Use this macro instead of `from++'. */ #define INC_FROM \ @@ -3188,7 +3181,7 @@ do { prev_from = from; \ temp = FETCH_CHAR_AS_MULTIBYTE (prev_from_byte); \ prev_prev_from_syntax = prev_from_syntax; \ prev_from_syntax = SYNTAX_WITH_FLAGS (temp); \ - INC_BOTH (from, from_byte); \ + inc_both (&from, &from_byte); \ if (from < end) \ UPDATE_SYNTAX_TABLE_FORWARD (from); \ } while (0) diff --git a/src/sysdep.c b/src/sysdep.c index cb2f7f2f23c..6b54ed3b6ec 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -27,6 +27,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #endif /* HAVE_PWD_H */ #include <limits.h> #include <stdlib.h> +#include <sys/random.h> #include <unistd.h> #include <c-ctype.h> @@ -115,16 +116,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "process.h" #include "cm.h" -#include "gnutls.h" -/* MS-Windows loads GnuTLS at run time, if available; we don't want to - do that during startup just to call gnutls_rnd. */ -#if defined HAVE_GNUTLS && !defined WINDOWSNT -# include <gnutls/crypto.h> -#else -# define emacs_gnutls_global_init() Qnil -# define gnutls_rnd(level, data, len) (-1) -#endif - #ifdef WINDOWSNT # include <direct.h> /* In process.h which conflicts with the local copy. */ @@ -135,11 +126,6 @@ int _cdecl _spawnlp (int, const char *, const char *, ...); # include <sys/socket.h> #endif -/* ULLONG_MAX is missing on Red Hat Linux 7.3; see Bug#11781. */ -#ifndef ULLONG_MAX -#define ULLONG_MAX TYPE_MAXIMUM (unsigned long long int) -#endif - /* Declare here, including term.h is problematic on some systems. */ extern void tputs (const char *, int, int (*)(int)); @@ -204,6 +190,7 @@ maybe_disable_address_randomization (int argc, char **argv) } #endif +#ifndef WINDOWSNT /* Execute the program in FILE, with argument vector ARGV and environ ENVP. Return an error number if unsuccessful. This is like execve except it reenables ASLR in the executed program if necessary, and @@ -220,6 +207,8 @@ emacs_exec_file (char const *file, char *const *argv, char *const *envp) return errno; } +#endif /* !WINDOWSNT */ + /* If FD is not already open, arrange for it to be open with FLAGS. */ static void force_open (int fd, int flags) @@ -317,8 +306,8 @@ get_current_dir_name_or_unreachable (void) if (pwd && (pwdlen = strnlen (pwd, bufsize_max)) < bufsize_max && IS_DIRECTORY_SEP (pwd[pwdlen && IS_DEVICE_SEP (pwd[1]) ? 2 : 0]) - && stat (pwd, &pwdstat) == 0 - && stat (".", &dotstat) == 0 + && emacs_fstatat (AT_FDCWD, pwd, &pwdstat, 0) == 0 + && emacs_fstatat (AT_FDCWD, ".", &dotstat, 0) == 0 && dotstat.st_ino == pwdstat.st_ino && dotstat.st_dev == pwdstat.st_dev) { @@ -2280,9 +2269,7 @@ init_signals (void) typedef unsigned int random_seed; static void set_random_seed (random_seed arg) { srandom (arg); } #elif defined HAVE_LRAND48 -/* Although srand48 uses a long seed, this is unsigned long to avoid - undefined behavior on signed integer overflow in init_random. */ -typedef unsigned long int random_seed; +typedef long int random_seed; static void set_random_seed (random_seed arg) { srand48 (arg); } #else typedef unsigned int random_seed; @@ -2309,23 +2296,14 @@ init_random (void) /* First, try seeding the PRNG from the operating system's entropy source. This approach is both fast and secure. */ #ifdef WINDOWSNT + /* FIXME: Perhaps getrandom can be used here too? */ success = w32_init_random (&v, sizeof v) == 0; #else - int fd = emacs_open ("/dev/urandom", O_RDONLY, 0); - if (0 <= fd) - { - success = emacs_read (fd, &v, sizeof v) == sizeof v; - close (fd); - } + verify (sizeof v <= 256); + success = getrandom (&v, sizeof v, 0) == sizeof v; #endif - /* If that didn't work, try using GnuTLS, which is secure, but on - some systems, can be somewhat slow. */ - if (!success) - success = EQ (emacs_gnutls_global_init (), Qt) - && gnutls_rnd (GNUTLS_RND_NONCE, &v, sizeof v) == 0; - - /* If _that_ didn't work, just use the current time value and PID. + /* If that didn't work, just use the current time value and PID. It's at least better than XKCD 221. */ if (!success) { @@ -2454,7 +2432,27 @@ emacs_abort (void) } #endif -/* Open FILE for Emacs use, using open flags OFLAG and mode MODE. +/* Assuming the directory DIRFD, store information about FILENAME into *ST, + using FLAGS to control how the status is obtained. + Do not fail merely because fetching info was interrupted by a signal. + Allow the user to quit. + + The type of ST is void * instead of struct stat * because the + latter type would be problematic in lisp.h. Some platforms may + play tricks like "#define stat stat64" in <sys/stat.h>, and lisp.h + does not include <sys/stat.h>. */ + +int +emacs_fstatat (int dirfd, char const *filename, void *st, int flags) +{ + int r; + while ((r = fstatat (dirfd, filename, st, flags)) != 0 && errno == EINTR) + maybe_quit (); + return r; +} + +/* Assuming the directory DIRFD, open FILE for Emacs use, + using open flags OFLAGS and mode MODE. Use binary I/O on systems that care about text vs binary I/O. Arrange for subprograms to not inherit the file descriptor. Prefer a method that is multithread-safe, if available. @@ -2462,17 +2460,23 @@ emacs_abort (void) Allow the user to quit. */ int -emacs_open (const char *file, int oflags, int mode) +emacs_openat (int dirfd, char const *file, int oflags, int mode) { int fd; if (! (oflags & O_TEXT)) oflags |= O_BINARY; oflags |= O_CLOEXEC; - while ((fd = open (file, oflags, mode)) < 0 && errno == EINTR) + while ((fd = openat (dirfd, file, oflags, mode)) < 0 && errno == EINTR) maybe_quit (); return fd; } +int +emacs_open (char const *file, int oflags, int mode) +{ + return emacs_openat (AT_FDCWD, file, oflags, mode); +} + /* Open FILE as a stream for Emacs use, with mode MODE. Act like emacs_open with respect to threads, signals, and quits. */ @@ -2731,21 +2735,6 @@ emacs_perror (char const *message) errno = err; } -/* Set the access and modification time stamps of FD (a.k.a. FILE) to be - ATIME and MTIME, respectively. - FD must be either negative -- in which case it is ignored -- - or a file descriptor that is open on FILE. - If FD is nonnegative, then FILE can be NULL. */ -int -set_file_times (int fd, const char *filename, - struct timespec atime, struct timespec mtime) -{ - struct timespec timespec[2]; - timespec[0] = atime; - timespec[1] = mtime; - return fdutimens (fd, filename, timespec); -} - /* Rename directory SRCFD's entry SRC to directory DSTFD's entry DST. This is like renameat except that it fails if DST already exists, or if this operation is not supported atomically. Return 0 if @@ -3141,7 +3130,7 @@ make_lisp_timeval (struct timeval t) #endif -#if defined GNU_LINUX && defined HAVE_LONG_LONG_INT +#ifdef GNU_LINUX static struct timespec time_from_jiffies (unsigned long long tval, long hz) { @@ -4127,14 +4116,20 @@ str_collate (Lisp_Object s1, Lisp_Object s2, len = SCHARS (s1); i = i_byte = 0; SAFE_NALLOCA (p1, 1, len + 1); while (i < len) - FETCH_STRING_CHAR_ADVANCE (*(p1+i-1), s1, i, i_byte); - *(p1+len) = 0; + { + wchar_t *p = &p1[i]; + *p = fetch_string_char_advance (s1, &i, &i_byte); + } + p1[len] = 0; len = SCHARS (s2); i = i_byte = 0; SAFE_NALLOCA (p2, 1, len + 1); while (i < len) - FETCH_STRING_CHAR_ADVANCE (*(p2+i-1), s2, i, i_byte); - *(p2+len) = 0; + { + wchar_t *p = &p2[i]; + *p = fetch_string_char_advance (s2, &i, &i_byte); + } + p2[len] = 0; if (STRINGP (locale)) { diff --git a/src/systhread.c b/src/systhread.c index 0d600d6895e..ebd75526495 100644 --- a/src/systhread.c +++ b/src/systhread.c @@ -26,6 +26,10 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "nsterm.h" #endif +#ifdef HAVE_PTHREAD_SET_NAME_NP +#include <pthread_np.h> +#endif + #ifndef THREADS_ENABLED void @@ -221,6 +225,10 @@ sys_thread_set_name (const char *name) # else pthread_setname_np (pthread_self (), p_name); # endif +#elif HAVE_PTHREAD_SET_NAME_NP + /* The name will automatically be truncated if it exceeds a + system-specific length. */ + pthread_set_name_np (pthread_self (), name); #endif } diff --git a/src/systhread.h b/src/systhread.h index 005388fd5a4..73c764a9401 100644 --- a/src/systhread.h +++ b/src/systhread.h @@ -21,12 +21,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <stdbool.h> -#if __has_attribute (warn_unused_result) -# define ATTRIBUTE_WARN_UNUSED_RESULT __attribute__ ((warn_unused_result)) -#else -# define ATTRIBUTE_WARN_UNUSED_RESULT -#endif - #ifdef THREADS_ENABLED #ifdef HAVE_PTHREAD @@ -108,13 +102,13 @@ extern void sys_cond_broadcast (sys_cond_t *); extern void sys_cond_destroy (sys_cond_t *); extern sys_thread_t sys_thread_self (void) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern bool sys_thread_equal (sys_thread_t, sys_thread_t) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern bool sys_thread_create (sys_thread_t *, thread_creation_function *, void *) - ATTRIBUTE_WARN_UNUSED_RESULT; + NODISCARD; extern void sys_thread_yield (void); extern void sys_thread_set_name (const char *); diff --git a/src/systime.h b/src/systime.h index 00ca4a1c58d..b59a3d1c690 100644 --- a/src/systime.h +++ b/src/systime.h @@ -67,9 +67,6 @@ timespec_valid_p (struct timespec t) return t.tv_nsec >= 0; } -/* defined in sysdep.c */ -extern int set_file_times (int, const char *, struct timespec, struct timespec); - /* defined in keyboard.c */ extern void set_waiting_for_input (struct timespec *); diff --git a/src/term.c b/src/term.c index 94bf013f4a0..5cbb092ad17 100644 --- a/src/term.c +++ b/src/term.c @@ -4168,6 +4168,15 @@ use the Bourne shell command 'TERM=...; export TERM' (C-shell:\n\ could return 32767. */ tty->TN_max_colors = 16777216; } + /* Fall back to xterm+direct (semicolon version) if requested + by the COLORTERM environment variable. */ + else if ((bg = getenv("COLORTERM")) != NULL + && strcasecmp(bg, "truecolor") == 0) + { + tty->TS_set_foreground = "\033[%?%p1%{8}%<%t3%p1%d%e38;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TS_set_background = "\033[%?%p1%{8}%<%t4%p1%d%e48;2;%p1%{65536}%/%d;%p1%{256}%/%{255}%&%d;%p1%{255}%&%d%;m"; + tty->TN_max_colors = 16777216; + } } #endif diff --git a/src/textprop.c b/src/textprop.c index ee048336ac0..0876badc873 100644 --- a/src/textprop.c +++ b/src/textprop.c @@ -131,6 +131,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, { INTERVAL i; ptrdiff_t searchpos; + Lisp_Object begin0 = *begin, end0 = *end; CHECK_STRING_OR_BUFFER (object); CHECK_FIXNUM_COERCE_MARKER (*begin); @@ -155,7 +156,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (!(BUF_BEGV (b) <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= BUF_ZV (b))) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = buffer_intervals (b); /* If there's no text, there are no properties. */ @@ -170,7 +171,7 @@ validate_interval_range (Lisp_Object object, Lisp_Object *begin, if (! (0 <= XFIXNUM (*begin) && XFIXNUM (*begin) <= XFIXNUM (*end) && XFIXNUM (*end) <= len)) - args_out_of_range (*begin, *end); + args_out_of_range (begin0, end0); i = string_intervals (object); if (len == 0) @@ -611,7 +612,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, { struct window *w = 0; - CHECK_FIXNUM_COERCE_MARKER (position); + EMACS_INT pos = fix_position (position); if (NILP (object)) XSETBUFFER (object, current_buffer); @@ -628,14 +629,14 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, Lisp_Object *overlay_vec; struct buffer *obuf = current_buffer; - if (XFIXNUM (position) < BUF_BEGV (XBUFFER (object)) - || XFIXNUM (position) > BUF_ZV (XBUFFER (object))) + if (! (BUF_BEGV (XBUFFER (object)) <= pos + && pos <= BUF_ZV (XBUFFER (object)))) xsignal1 (Qargs_out_of_range, position); set_buffer_temp (XBUFFER (object)); USE_SAFE_ALLOCA; - GET_OVERLAYS_AT (XFIXNUM (position), overlay_vec, noverlays, NULL, false); + GET_OVERLAYS_AT (pos, overlay_vec, noverlays, NULL, false); noverlays = sort_overlays (overlay_vec, noverlays, w); set_buffer_temp (obuf); @@ -662,7 +663,7 @@ get_char_property_and_overlay (Lisp_Object position, register Lisp_Object prop, /* Not a buffer, or no appropriate overlay, so fall through to the simpler case. */ - return Fget_text_property (position, prop, object); + return Fget_text_property (make_fixnum (pos), prop, object); } DEFUN ("get-char-property", Fget_char_property, Sget_char_property, 2, 3, 0, @@ -765,14 +766,13 @@ the current buffer), POSITION is a buffer position (integer or marker). If OBJECT is a string, POSITION is a 0-based index into it. In a string, scan runs to the end of the string, unless LIMIT is non-nil. -In a buffer, if LIMIT is nil or omitted, it runs to (point-max), and the -value cannot exceed that. +In a buffer, scan runs to end of buffer, unless LIMIT is non-nil. If the optional fourth argument LIMIT is non-nil, don't search past position LIMIT; return LIMIT if nothing is found before LIMIT. +However, if OBJECT is a buffer and LIMIT is beyond the end of the +buffer, this function returns `point-max', not LIMIT. -The property values are compared with `eq'. -If the property is constant all the way to the end of OBJECT, return the -last valid position in OBJECT. */) +The property values are compared with `eq'. */) (Lisp_Object position, Lisp_Object prop, Lisp_Object object, Lisp_Object limit) { if (STRINGP (object)) @@ -831,6 +831,9 @@ last valid position in OBJECT. */) value = Fget_char_property (position, prop, object); if (!EQ (value, initial_value)) break; + + if (XFIXNAT (position) >= ZV) + break; } position = unbind_to (count, position); diff --git a/src/thread.c b/src/thread.c index c7fe0614269..b638dd77f8b 100644 --- a/src/thread.c +++ b/src/thread.c @@ -717,12 +717,17 @@ run_thread (void *state) { /* Make sure stack_top and m_stack_bottom are properly aligned as GC expects. */ - max_align_t stack_pos; + union + { + Lisp_Object o; + void *p; + char c; + } stack_pos; struct thread_state *self = state; struct thread_state **iter; - self->m_stack_bottom = self->stack_top = (char *) &stack_pos; + self->m_stack_bottom = self->stack_top = &stack_pos.c; self->thread_id = sys_thread_self (); if (self->thread_name) @@ -1114,9 +1119,6 @@ syms_of_threads (void) staticpro (&last_thread_error); last_thread_error = Qnil; - Fdefalias (intern_c_string ("thread-alive-p"), - intern_c_string ("thread-live-p"), Qnil); - Fprovide (intern_c_string ("threads"), Qnil); } diff --git a/src/timefns.c b/src/timefns.c index 553daf6e6a9..7bcc37d7c1e 100644 --- a/src/timefns.c +++ b/src/timefns.c @@ -593,31 +593,29 @@ timespec_to_lisp (struct timespec t) } /* Return NUMERATOR / DENOMINATOR, rounded to the nearest double. - Arguments must be Lisp integers, and DENOMINATOR must be nonzero. */ + Arguments must be Lisp integers, and DENOMINATOR must be positive. */ static double frac_to_double (Lisp_Object numerator, Lisp_Object denominator) { - intmax_t intmax_numerator; - if (FASTER_TIMEFNS && EQ (denominator, make_fixnum (1)) - && integer_to_intmax (numerator, &intmax_numerator)) - return intmax_numerator; + intmax_t intmax_numerator, intmax_denominator; + if (FASTER_TIMEFNS + && integer_to_intmax (numerator, &intmax_numerator) + && integer_to_intmax (denominator, &intmax_denominator) + && intmax_numerator % intmax_denominator == 0) + return intmax_numerator / intmax_denominator; /* Compute number of base-FLT_RADIX digits in numerator and denominator. */ mpz_t const *n = bignum_integer (&mpz[0], numerator); mpz_t const *d = bignum_integer (&mpz[1], denominator); - ptrdiff_t nbits = mpz_sizeinbase (*n, 2); - ptrdiff_t dbits = mpz_sizeinbase (*d, 2); - eassume (0 < nbits); - eassume (0 < dbits); - ptrdiff_t ndig = (nbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; - ptrdiff_t ddig = (dbits + LOG2_FLT_RADIX - 1) / LOG2_FLT_RADIX; + ptrdiff_t ndig = mpz_sizeinbase (*n, FLT_RADIX); + ptrdiff_t ddig = mpz_sizeinbase (*d, FLT_RADIX); /* Scale with SCALE when doing integer division. That is, compute (N * FLT_RADIX**SCALE) / D [or, if SCALE is negative, N / (D * FLT_RADIX**-SCALE)] as a bignum, convert the bignum to double, then divide the double by FLT_RADIX**SCALE. First scale N (or scale D, if SCALE is negative) ... */ - ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG + 1; + ptrdiff_t scale = ddig - ndig + DBL_MANT_DIG; if (scale < 0) { mpz_mul_2exp (mpz[1], *d, - (scale * LOG2_FLT_RADIX)); @@ -645,7 +643,7 @@ frac_to_double (Lisp_Object numerator, Lisp_Object denominator) round to the nearest integer; otherwise, it is less than FLT_RADIX ** (DBL_MANT_DIG + 1) and round it to the nearest multiple of FLT_RADIX. Break ties to even. */ - if (mpz_sizeinbase (*q, 2) < DBL_MANT_DIG * LOG2_FLT_RADIX) + if (mpz_sizeinbase (*q, FLT_RADIX) <= DBL_MANT_DIG) { /* Converting to double will use the whole quotient so add 1 to its absolute value as per round-to-even; i.e., if the doubled @@ -770,44 +768,48 @@ decode_time_components (enum timeform form, /* Normalize out-of-range lower-order components by carrying each overflow into the next higher-order component. */ us += ps / 1000000 - (ps % 1000000 < 0); - mpz_set_intmax (mpz[0], us / 1000000 - (us % 1000000 < 0)); - mpz_add (mpz[0], mpz[0], *bignum_integer (&mpz[1], low)); - mpz_addmul_ui (mpz[0], *bignum_integer (&mpz[1], high), 1 << LO_TIME_BITS); + mpz_t *s = &mpz[1]; + mpz_set_intmax (*s, us / 1000000 - (us % 1000000 < 0)); + mpz_add (*s, *s, *bignum_integer (&mpz[0], low)); + mpz_addmul_ui (*s, *bignum_integer (&mpz[0], high), 1 << LO_TIME_BITS); ps = ps % 1000000 + 1000000 * (ps % 1000000 < 0); us = us % 1000000 + 1000000 * (us % 1000000 < 0); - if (result) + Lisp_Object hz; + switch (form) { - switch (form) - { - case TIMEFORM_HI_LO: - /* Floats and nil were handled above, so it was an integer. */ - result->hz = make_fixnum (1); - break; - - case TIMEFORM_HI_LO_US: - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], us); - result->hz = make_fixnum (1000000); - break; - - case TIMEFORM_HI_LO_US_PS: - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], us); - mpz_mul_ui (mpz[0], mpz[0], 1000000); - mpz_add_ui (mpz[0], mpz[0], ps); - result->hz = trillion; - break; - - default: - eassume (false); - } - result->ticks = make_integer_mpz (); + case TIMEFORM_HI_LO: + /* Floats and nil were handled above, so it was an integer. */ + mpz_swap (mpz[0], *s); + hz = make_fixnum (1); + break; + + case TIMEFORM_HI_LO_US: + mpz_set_ui (mpz[0], us); + mpz_addmul_ui (mpz[0], *s, 1000000); + hz = make_fixnum (1000000); + break; + + case TIMEFORM_HI_LO_US_PS: + { + #if FASTER_TIMEFNS && TRILLION <= ULONG_MAX + unsigned long i = us; + mpz_set_ui (mpz[0], i * 1000000 + ps); + mpz_addmul_ui (mpz[0], *s, TRILLION); + #else + intmax_t i = us; + mpz_set_intmax (mpz[0], i * 1000000 + ps); + mpz_addmul (mpz[0], *s, ztrillion); + #endif + hz = trillion; + } + break; + + default: + eassume (false); } - else - *dresult = mpz_get_d (mpz[0]) + (us * 1e6L + ps) / 1e12L; - return 0; + return decode_ticks_hz (make_integer_mpz (), hz, result, dresult); } enum { DECODE_SECS_ONLY = WARN_OBSOLETE_TIMESTAMPS + 1 }; diff --git a/src/w32.c b/src/w32.c index 78e75f0937e..f391f5e26eb 100644 --- a/src/w32.c +++ b/src/w32.c @@ -2370,6 +2370,26 @@ srandom (int seed) iz = rand () % RAND_MAX_Z; } +/* Emulate explicit_bzero. This is to avoid using the Gnulib version, + because it calls SecureZeroMemory at will, disregarding systems + older than Windows XP, which didn't have that function. We want to + avoid having that function as dependency in builds that need to + support systems older than Windows XP, otherwise Emacs will refuse + to start on those systems. */ +void +explicit_bzero (void *buf, size_t len) +{ +#if _WIN32_WINNT >= 0x0501 + /* We are compiling for XP or newer, most probably with MinGW64. + We can use SecureZeroMemory. */ + SecureZeroMemory (buf, len); +#else + memset (buf, 0, len); + /* Compiler barrier. */ + asm volatile ("" ::: "memory"); +#endif +} + /* Return the maximum length in bytes of a multibyte character sequence encoded in the current ANSI codepage. This is required to correctly walk the encoded file names one character at a time. */ @@ -3178,18 +3198,9 @@ fdutimens (int fd, char const *file, struct timespec const timespec[2]) return _futime (fd, &_ut); } else - { - struct utimbuf ut; - - ut.actime = timespec[0].tv_sec; - ut.modtime = timespec[1].tv_sec; - /* Call 'utime', which is implemented below, not the MS library - function, which fails on directories. */ - return utime (file, &ut); - } + return utimensat (fd, file, timespec, 0); } - /* ------------------------------------------------------------------------- */ /* IO support and wrapper functions for the Windows API. */ /* ------------------------------------------------------------------------- */ @@ -3450,8 +3461,6 @@ is_fat_volume (const char * name, const char ** pPath) /* Convert all slashes in a filename to backslashes, and map filename to a valid 8.3 name if necessary. The result is a pointer to a static buffer, so CAVEAT EMPTOR! */ -const char *map_w32_filename (const char *, const char **); - const char * map_w32_filename (const char * name, const char ** pPath) { @@ -4320,10 +4329,9 @@ sys_chdir (const char * path) } } -int -sys_chmod (const char * path, int mode) +static int +chmod_worker (const char * path, int mode) { - path = chase_symlinks (map_w32_filename (path, NULL)); if (w32_unicode_filenames) { wchar_t path_w[MAX_PATH]; @@ -4341,6 +4349,20 @@ sys_chmod (const char * path, int mode) } int +sys_chmod (const char * path, int mode) +{ + path = chase_symlinks (map_w32_filename (path, NULL)); + return chmod_worker (path, mode); +} + +int +lchmod (const char * path, mode_t mode) +{ + path = map_w32_filename (path, NULL); + return chmod_worker (path, mode); +} + +int sys_creat (const char * path, int mode) { path = map_w32_filename (path, NULL); @@ -4592,12 +4614,55 @@ sys_open (const char * path, int oflag, int mode) } int +openat (int fd, const char * path, int oflag, int mode) +{ + /* Rely on a hack: an open directory is modeled as file descriptor 0, + as in fstatat. FIXME: Add proper support for openat. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + if (_snprintf (fullname, sizeof fullname, "%s/%s", dir_pathname, path) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + path = fullname; + } + + return sys_open (path, oflag, mode); +} + +int fchmod (int fd, mode_t mode) { return 0; } int +fchmodat (int fd, char const *path, mode_t mode, int flags) +{ + /* Rely on a hack: an open directory is modeled as file descriptor 0, + as in fstatat. FIXME: Add proper support for fchmodat. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + if (_snprintf (fullname, sizeof fullname, "%s/%s", dir_pathname, path) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + path = fullname; + } + + return + flags == AT_SYMLINK_NOFOLLOW ? lchmod (path, mode) : sys_chmod (path, mode); +} + +int sys_rename_replace (const char *oldname, const char *newname, BOOL force) { BOOL result; @@ -4914,7 +4979,7 @@ convert_time (FILETIME ft) } static void -convert_from_time_t (time_t time, FILETIME * pft) +convert_from_timespec (struct timespec time, FILETIME * pft) { ULARGE_INTEGER tmp; @@ -4925,7 +4990,8 @@ convert_from_time_t (time_t time, FILETIME * pft) } /* time in 100ns units since 1-Jan-1601 */ - tmp.QuadPart = (ULONGLONG) time * 10000000L + utc_base; + tmp.QuadPart = + (ULONGLONG) time.tv_sec * 10000000L + time.tv_nsec / 100 + utc_base; pft->dwHighDateTime = tmp.HighPart; pft->dwLowDateTime = tmp.LowPart; } @@ -5592,8 +5658,8 @@ fstatat (int fd, char const *name, struct stat *st, int flags) return stat_worker (name, st, ! (flags & AT_SYMLINK_NOFOLLOW)); } -/* Provide fstat and utime as well as stat for consistent handling of - file timestamps. */ +/* Provide fstat and utimensat as well as stat for consistent handling + of file timestamps. */ int fstat (int desc, struct stat * buf) { @@ -5704,23 +5770,65 @@ fstat (int desc, struct stat * buf) return 0; } -/* A version of 'utime' which handles directories as well as - files. */ +/* Emulate utimensat. */ int -utime (const char *name, struct utimbuf *times) +utimensat (int fd, const char *name, const struct timespec times[2], int flag) { - struct utimbuf deftime; + struct timespec ltimes[2]; HANDLE fh; FILETIME mtime; FILETIME atime; + DWORD flags_and_attrs = FILE_FLAG_BACKUP_SEMANTICS; + + /* Rely on a hack: an open directory is modeled as file descriptor 0. + This is good enough for the current usage in Emacs, but is fragile. + + FIXME: Add proper support for utimensat. + Gnulib does this and can serve as a model. */ + char fullname[MAX_UTF8_PATH]; + + if (fd != AT_FDCWD) + { + char lastc = dir_pathname[strlen (dir_pathname) - 1]; + + if (_snprintf (fullname, sizeof fullname, "%s%s%s", + dir_pathname, IS_DIRECTORY_SEP (lastc) ? "" : "/", name) + < 0) + { + errno = ENAMETOOLONG; + return -1; + } + name = fullname; + } if (times == NULL) { - deftime.modtime = deftime.actime = time (NULL); - times = &deftime; + memset (ltimes, 0, sizeof (ltimes)); + ltimes[0] = ltimes[1] = current_timespec (); + } + else + { + if (times[0].tv_nsec == UTIME_OMIT && times[1].tv_nsec == UTIME_OMIT) + return 0; /* nothing to do */ + if ((times[0].tv_nsec != UTIME_NOW && times[0].tv_nsec != UTIME_OMIT + && !(0 <= times[0].tv_nsec && times[0].tv_nsec < 1000000000)) + || (times[1].tv_nsec != UTIME_NOW && times[1].tv_nsec != UTIME_OMIT + && !(0 <= times[1].tv_nsec && times[1].tv_nsec < 1000000000))) + { + errno = EINVAL; /* reject invalid timespec values */ + return -1; + } + + memcpy (ltimes, times, sizeof (ltimes)); + if (ltimes[0].tv_nsec == UTIME_NOW) + ltimes[0] = current_timespec (); + if (ltimes[1].tv_nsec == UTIME_NOW) + ltimes[1] = current_timespec (); } + if (flag == AT_SYMLINK_NOFOLLOW) + flags_and_attrs |= FILE_FLAG_OPEN_REPARSE_POINT; if (w32_unicode_filenames) { wchar_t name_utf16[MAX_PATH]; @@ -5734,7 +5842,7 @@ utime (const char *name, struct utimbuf *times) allows other processes to delete files inside it, while we have the directory open. */ FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, - 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + 0, OPEN_EXISTING, flags_and_attrs, NULL); } else { @@ -5745,13 +5853,26 @@ utime (const char *name, struct utimbuf *times) fh = CreateFileA (name_ansi, FILE_WRITE_ATTRIBUTES, FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE, - 0, OPEN_EXISTING, FILE_FLAG_BACKUP_SEMANTICS, NULL); + 0, OPEN_EXISTING, flags_and_attrs, NULL); } if (fh != INVALID_HANDLE_VALUE) { - convert_from_time_t (times->actime, &atime); - convert_from_time_t (times->modtime, &mtime); - if (!SetFileTime (fh, NULL, &atime, &mtime)) + FILETIME *patime, *pmtime; + if (ltimes[0].tv_nsec == UTIME_OMIT) + patime = NULL; + else + { + convert_from_timespec (ltimes[0], &atime); + patime = &atime; + } + if (ltimes[1].tv_nsec == UTIME_OMIT) + pmtime = NULL; + else + { + convert_from_timespec (ltimes[1], &mtime); + pmtime = &mtime; + } + if (!SetFileTime (fh, NULL, patime, pmtime)) { CloseHandle (fh); errno = EACCES; @@ -6680,16 +6801,16 @@ w32_copy_file (const char *from, const char *to, FIXME? */ else if (!keep_time) { - struct timespec now; + struct timespec tnow[2]; DWORD attributes; + tnow[0] = tnow[1] = current_timespec (); if (w32_unicode_filenames) { /* Ensure file is writable while its times are set. */ attributes = GetFileAttributesW (to_w); SetFileAttributesW (to_w, attributes & ~FILE_ATTRIBUTE_READONLY); - now = current_timespec (); - if (set_file_times (-1, to, now, now)) + if (utimensat (AT_FDCWD, to, tnow, 0)) { /* Restore original attributes. */ SetFileAttributesW (to_w, attributes); @@ -6704,8 +6825,7 @@ w32_copy_file (const char *from, const char *to, { attributes = GetFileAttributesA (to_a); SetFileAttributesA (to_a, attributes & ~FILE_ATTRIBUTE_READONLY); - now = current_timespec (); - if (set_file_times (-1, to, now, now)) + if (utimensat (AT_FDCWD, to, tnow, 0)) { SetFileAttributesA (to_a, attributes); if (acl) @@ -10133,6 +10253,10 @@ term_ntproc (int ignored) term_winsock (); term_w32select (); + +#if HAVE_NATIVE_IMAGE_API + w32_gdiplus_shutdown (); +#endif } void diff --git a/src/w32.h b/src/w32.h index b8655ec788c..1afb8ad0873 100644 --- a/src/w32.h +++ b/src/w32.h @@ -194,6 +194,7 @@ extern void syms_of_ntproc (void); extern void syms_of_ntterm (void); extern void dostounix_filename (register char *); extern void unixtodos_filename (register char *); +extern const char *map_w32_filename (const char *, const char **); extern int filename_from_ansi (const char *, char *); extern int filename_to_ansi (const char *, char *); extern int filename_from_utf16 (const wchar_t *, char *); @@ -221,6 +222,9 @@ extern void register_child (pid_t, int); extern void sys_sleep (int); extern int sys_link (const char *, const char *); +extern int openat (int, const char *, int, int); +extern int fchmodat (int, char const *, mode_t, int); +extern int lchmod (char const *, mode_t); /* Return total and free memory info. */ extern int w32_memory_info (unsigned long long *, unsigned long long *, diff --git a/src/w32fns.c b/src/w32fns.c index 2f01fb52e92..ab864332e78 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -80,7 +80,6 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ extern int w32_console_toggle_lock_key (int, Lisp_Object); extern void w32_menu_display_help (HWND, HMENU, UINT, UINT); extern void w32_free_menu_strings (HWND); -extern const char *map_w32_filename (const char *, const char **); #ifndef IDC_HAND #define IDC_HAND MAKEINTRESOURCE(32649) @@ -166,6 +165,10 @@ typedef HIMC (WINAPI * ImmGetContext_Proc) (IN HWND window); typedef BOOL (WINAPI * ImmReleaseContext_Proc) (IN HWND wnd, IN HIMC context); typedef BOOL (WINAPI * ImmSetCompositionWindow_Proc) (IN HIMC context, IN COMPOSITIONFORM *form); +/* For toggling IME status. */ +typedef BOOL (WINAPI * ImmGetOpenStatus_Proc) (IN HIMC); +typedef BOOL (WINAPI * ImmSetOpenStatus_Proc) (IN HIMC, IN BOOL); + typedef HMONITOR (WINAPI * MonitorFromPoint_Proc) (IN POINT pt, IN DWORD flags); typedef BOOL (WINAPI * GetMonitorInfo_Proc) (IN HMONITOR monitor, OUT struct MONITOR_INFO* info); @@ -185,6 +188,8 @@ typedef HRESULT (WINAPI *SetThreadDescription_Proc) TrackMouseEvent_Proc track_mouse_event_fn = NULL; ImmGetCompositionString_Proc get_composition_string_fn = NULL; ImmGetContext_Proc get_ime_context_fn = NULL; +ImmGetOpenStatus_Proc get_ime_open_status_fn = NULL; +ImmSetOpenStatus_Proc set_ime_open_status_fn = NULL; ImmReleaseContext_Proc release_ime_context_fn = NULL; ImmSetCompositionWindow_Proc set_ime_composition_window_fn = NULL; MonitorFromPoint_Proc monitor_from_point_fn = NULL; @@ -859,161 +864,14 @@ x_to_w32_color (const char * colorname) block_input (); - if (colorname[0] == '#') + unsigned short r, g, b; + if (parse_color_spec (colorname, &r, &g, &b)) { - /* Could be an old-style RGB Device specification. */ - int size = strlen (colorname + 1); - char *color = alloca (size + 1); - - strcpy (color, colorname + 1); - if (size == 3 || size == 6 || size == 9 || size == 12) - { - UINT colorval; - int i, pos; - pos = 0; - size /= 3; - colorval = 0; - - for (i = 0; i < 3; i++) - { - char *end; - char t; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - t = color[size]; - color[size] = '\0'; - value = strtoul (color, &end, 16); - color[size] = t; - if (errno == ERANGE || end - color != size) - break; - switch (size) - { - case 1: - value = value * 0x10; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - } - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - color = end; - } - } - } - else if (strnicmp (colorname, "rgb:", 4) == 0) - { - const char *color; - UINT colorval; - int i, pos; - pos = 0; - - colorval = 0; - color = colorname + 4; - for (i = 0; i < 3; i++) - { - char *end; - unsigned long value; - - /* The check for 'x' in the following conditional takes into - account the fact that strtol allows a "0x" in front of - our numbers, and we don't. */ - if (!isxdigit (color[0]) || color[1] == 'x') - break; - value = strtoul (color, &end, 16); - if (errno == ERANGE) - break; - switch (end - color) - { - case 1: - value = value * 0x10 + value; - break; - case 2: - break; - case 3: - value /= 0x10; - break; - case 4: - value /= 0x100; - break; - default: - value = ULONG_MAX; - } - if (value == ULONG_MAX) - break; - colorval |= (value << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } + unblock_input (); + /* Throw away the low 8 bits and return 0xBBGGRR. */ + return make_fixnum ((b & 0xff00) << 8 | (g & 0xff00) | r >> 8); } - else if (strnicmp (colorname, "rgbi:", 5) == 0) - { - /* This is an RGB Intensity specification. */ - const char *color; - UINT colorval; - int i, pos; - pos = 0; - - colorval = 0; - color = colorname + 5; - for (i = 0; i < 3; i++) - { - char *end; - double value; - UINT val; - value = strtod (color, &end); - if (errno == ERANGE) - break; - if (value < 0.0 || value > 1.0) - break; - val = (UINT)(0x100 * value); - /* We used 0x100 instead of 0xFF to give a continuous - range between 0.0 and 1.0 inclusive. The next statement - fixes the 1.0 case. */ - if (val == 0x100) - val = 0xFF; - colorval |= (val << pos); - pos += 0x8; - if (i == 2) - { - if (*end != '\0') - break; - unblock_input (); - XSETINT (ret, colorval); - return ret; - } - if (*end != '/') - break; - color = end + 1; - } - } /* I am not going to attempt to handle any of the CIE color schemes or TekHVC, since I don't know the algorithms for conversion to RGB. */ @@ -1700,10 +1558,8 @@ w32_clear_under_internal_border (struct frame *f) static void w32_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - int border; - - CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XFIXNUM (arg), 0); + int argval = check_integer_range (arg, INT_MIN, INT_MAX); + int border = max (argval, 0); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -3307,6 +3163,7 @@ w32_name_of_message (UINT msg) M (WM_EMACS_SETCURSOR), M (WM_EMACS_SHOWCURSOR), M (WM_EMACS_PAINT), + M (WM_EMACS_IME_STATUS), M (WM_CHAR), #undef M { 0, 0 } @@ -3444,6 +3301,21 @@ w32_msg_pump (deferred_msg * msg_buf) emacs_abort (); } break; + case WM_EMACS_IME_STATUS: + { + focus_window = GetFocus (); + if (!set_ime_open_status_fn || !focus_window) + break; + + HIMC context = get_ime_context_fn (focus_window); + if (!context) + break; + + set_ime_open_status_fn (context, msg.wParam != 0); + release_ime_context_fn (focus_window, context); + break; + } + #ifdef MSG_DEBUG /* Broadcast messages make it here, so you need to be looking for something in particular for this to be useful. */ @@ -8260,7 +8132,6 @@ a ShowWindow flag: /* Encode filename, current directory and parameters. */ current_dir = GUI_ENCODE_FILE (current_dir); document = GUI_ENCODE_FILE (document); - doc_w = GUI_SDATA (document); if (STRINGP (parameters)) { parameters = GUI_ENCODE_SYSTEM (parameters); @@ -8271,6 +8142,7 @@ a ShowWindow flag: operation = GUI_ENCODE_SYSTEM (operation); ops_w = GUI_SDATA (operation); } + doc_w = GUI_SDATA (document); result = (intptr_t) ShellExecuteW (NULL, ops_w, doc_w, params_w, GUI_SDATA (current_dir), (FIXNUMP (show_flag) @@ -8355,7 +8227,7 @@ a ShowWindow flag: handler = Ffind_file_name_handler (absdoc, Qfile_exists_p); if (NILP (handler)) { - Lisp_Object absdoc_encoded = ENCODE_FILE (absdoc); + Lisp_Object absdoc_encoded = Fcopy_sequence (ENCODE_FILE (absdoc)); if (faccessat (AT_FDCWD, SSDATA (absdoc_encoded), F_OK, AT_EACCESS) == 0) { @@ -9203,8 +9075,8 @@ The coordinates X and Y are interpreted in pixels relative to a position UINT trail_num = 0; BOOL ret = false; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); block_input (); /* When "mouse trails" are in effect, moving the mouse cursor @@ -9213,7 +9085,7 @@ The coordinates X and Y are interpreted in pixels relative to a position if (os_subtype == OS_NT && w32_major_version + w32_minor_version >= 6) ret = SystemParametersInfo (SPI_GETMOUSETRAILS, 0, &trail_num, 0); - SetCursorPos (XFIXNUM (x), XFIXNUM (y)); + SetCursorPos (xval, yval); if (ret) SystemParametersInfo (SPI_SETMOUSETRAILS, trail_num, NULL, 0); unblock_input (); @@ -10220,6 +10092,51 @@ DEFUN ("w32-notification-close", #endif /* WINDOWSNT && !HAVE_DBUS */ +DEFUN ("w32-get-ime-open-status", + Fw32_get_ime_open_status, Sw32_get_ime_open_status, + 0, 0, 0, + doc: /* Return non-nil if IME is active, otherwise return nil. + +IME, the MS-Windows Input Method Editor, can be active or inactive. +This function returns non-nil if the IME is active, otherwise nil. */) + (void) +{ + struct frame *sf = + FRAMEP (selected_frame) && FRAME_LIVE_P (XFRAME (selected_frame)) + ? XFRAME (selected_frame) + : NULL; + + if (sf) + { + HWND current_window = FRAME_W32_WINDOW (sf); + HIMC context = get_ime_context_fn (current_window); + if (context) + { + BOOL retval = get_ime_open_status_fn (context); + release_ime_context_fn (current_window, context); + + return retval ? Qt : Qnil; + } + } + + return Qnil; +} + +DEFUN ("w32-set-ime-open-status", + Fw32_set_ime_open_status, Sw32_set_ime_open_status, + 1, 1, 0, + doc: /* Open or close the IME according to STATUS. + +This function activates the IME, the MS-Windows Input Method Editor, +if STATUS is non-nil, otherwise it deactivates the IME. */) + (Lisp_Object status) +{ + unsigned ime_status = NILP (status) ? 0 : 1; + + PostThreadMessage (dwWindowsThreadId, WM_EMACS_IME_STATUS, ime_status, 0); + return Qnil; +} + #ifdef WINDOWSNT /*********************************************************************** @@ -10746,6 +10663,8 @@ tip frame. */); defsubr (&Sw32_notification_notify); defsubr (&Sw32_notification_close); #endif + defsubr (&Sw32_get_ime_open_status); + defsubr (&Sw32_set_ime_open_status); #ifdef WINDOWSNT defsubr (&Sw32_read_registry); @@ -11034,6 +10953,11 @@ globals_of_w32fns (void) get_proc_addr (imm32_lib, "ImmReleaseContext"); set_ime_composition_window_fn = (ImmSetCompositionWindow_Proc) get_proc_addr (imm32_lib, "ImmSetCompositionWindow"); + + get_ime_open_status_fn = (ImmGetOpenStatus_Proc) + get_proc_addr (imm32_lib, "ImmGetOpenStatus"); + set_ime_open_status_fn = (ImmSetOpenStatus_Proc) + get_proc_addr (imm32_lib, "ImmSetOpenStatus"); } HMODULE hm_kernel32 = GetModuleHandle ("kernel32.dll"); diff --git a/src/w32gui.h b/src/w32gui.h index 5cc64287291..dfec1f08617 100644 --- a/src/w32gui.h +++ b/src/w32gui.h @@ -41,6 +41,12 @@ typedef struct _XImage /* Optional RGBQUAD array for palette follows (see BITMAPINFO docs). */ } XImage; +struct image; +extern int w32_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data); +extern bool w32_can_use_native_image_api (Lisp_Object); +extern void w32_gdiplus_shutdown (void); + #define FACE_DEFAULT (~0) extern HINSTANCE hinst; diff --git a/src/w32heap.c b/src/w32heap.c index 3a6c7804675..ececc73c026 100644 --- a/src/w32heap.c +++ b/src/w32heap.c @@ -597,6 +597,16 @@ free_after_dump_9x (void *ptr) } } +void * +sys_calloc (size_t number, size_t size) +{ + size_t nbytes = number * size; + void *ptr = (*the_malloc_fn) (nbytes); + if (ptr) + memset (ptr, 0, nbytes); + return ptr; +} + #if defined HAVE_UNEXEC && defined ENABLE_CHECKING void report_temacs_memory_usage (void) diff --git a/src/w32image.c b/src/w32image.c new file mode 100644 index 00000000000..70b2eb29b87 --- /dev/null +++ b/src/w32image.c @@ -0,0 +1,477 @@ +/* Implementation of MS-Windows native image API via the GDI+ library. + +Copyright (C) 2020 Free Software Foundation, Inc. + +This file is part of GNU Emacs. + +GNU Emacs is free software: you can redistribute it and/or modify +it under the terms of the GNU General Public License as published by +the Free Software Foundation, either version 3 of the License, or (at +your option) any later version. + +GNU Emacs is distributed in the hope that it will be useful, +but WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +GNU General Public License for more details. + +You should have received a copy of the GNU General Public License +along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ + +/* Written by Juan Jose Garcia-Ripoll <juanjose.garciaripoll@gmail.com>. */ + +#include <config.h> +#include "lisp.h" +#include "dispextern.h" +#define COBJMACROS +#ifdef MINGW_W64 +/* FIXME: Do we need to include objidl.h? */ +#include <objidl.h> +#endif +#include <wtypes.h> +#include <gdiplus.h> +#include <shlwapi.h> +#include "w32common.h" +#include "w32term.h" +#ifdef WINDOWSNT +#include "w32.h" /* for map_w32_filename, filename_to_utf16 */ +#endif +#include "frame.h" +#include "coding.h" + +#ifdef WINDOWSNT + +typedef GpStatus (WINGDIPAPI *GdiplusStartup_Proc) + (ULONG_PTR *, GdiplusStartupInput *, GdiplusStartupOutput *); +typedef VOID (WINGDIPAPI *GdiplusShutdown_Proc) (ULONG_PTR); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItemSize_Proc) + (GpImage *, PROPID, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetPropertyItem_Proc) + (GpImage *, PROPID, UINT, PropertyItem *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsCount_Proc) + (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameDimensionsList_Proc) + (GpImage *, GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipImageGetFrameCount_Proc) + (GpImage *, GDIPCONST GUID *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipImageSelectActiveFrame_Proc) + (GpImage*, GDIPCONST GUID *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromFile_Proc) + (WCHAR *, GpBitmap **); +typedef GpStatus (WINGDIPAPI *GdipCreateBitmapFromStream_Proc) + (IStream *, GpBitmap **); +typedef IStream * (WINAPI *SHCreateMemStream_Proc) (const BYTE *, UINT); +typedef GpStatus (WINGDIPAPI *GdipCreateHBITMAPFromBitmap_Proc) + (GpBitmap *, HBITMAP *, ARGB); +typedef GpStatus (WINGDIPAPI *GdipDisposeImage_Proc) (GpImage *); +typedef GpStatus (WINGDIPAPI *GdipGetImageHeight_Proc) (GpImage *, UINT *); +typedef GpStatus (WINGDIPAPI *GdipGetImageWidth_Proc) (GpImage *, UINT *); + +GdiplusStartup_Proc fn_GdiplusStartup; +GdiplusShutdown_Proc fn_GdiplusShutdown; +GdipGetPropertyItemSize_Proc fn_GdipGetPropertyItemSize; +GdipGetPropertyItem_Proc fn_GdipGetPropertyItem; +GdipImageGetFrameDimensionsCount_Proc fn_GdipImageGetFrameDimensionsCount; +GdipImageGetFrameDimensionsList_Proc fn_GdipImageGetFrameDimensionsList; +GdipImageGetFrameCount_Proc fn_GdipImageGetFrameCount; +GdipImageSelectActiveFrame_Proc fn_GdipImageSelectActiveFrame; +GdipCreateBitmapFromFile_Proc fn_GdipCreateBitmapFromFile; +GdipCreateBitmapFromStream_Proc fn_GdipCreateBitmapFromStream; +SHCreateMemStream_Proc fn_SHCreateMemStream; +GdipCreateHBITMAPFromBitmap_Proc fn_GdipCreateHBITMAPFromBitmap; +GdipDisposeImage_Proc fn_GdipDisposeImage; +GdipGetImageHeight_Proc fn_GdipGetImageHeight; +GdipGetImageWidth_Proc fn_GdipGetImageWidth; + +static bool +gdiplus_init (void) +{ + HANDLE gdiplus_lib, shlwapi_lib; + + if (!((gdiplus_lib = w32_delayed_load (Qgdiplus)) + && (shlwapi_lib = w32_delayed_load (Qshlwapi)))) + return false; + + fn_GdiplusStartup = (GdiplusStartup_Proc) + get_proc_addr (gdiplus_lib, "GdiplusStartup"); + if (!fn_GdiplusStartup) + return false; + fn_GdiplusShutdown = (GdiplusShutdown_Proc) + get_proc_addr (gdiplus_lib, "GdiplusShutdown"); + if (!fn_GdiplusShutdown) + return false; + fn_GdipGetPropertyItemSize = (GdipGetPropertyItemSize_Proc) + get_proc_addr (gdiplus_lib, "GdipGetPropertyItemSize"); + if (!fn_GdipGetPropertyItemSize) + return false; + fn_GdipGetPropertyItem = (GdipGetPropertyItem_Proc) + get_proc_addr (gdiplus_lib, "GdipGetPropertyItem"); + if (!fn_GdipGetPropertyItem) + return false; + fn_GdipImageGetFrameDimensionsCount = (GdipImageGetFrameDimensionsCount_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameDimensionsCount"); + if (!fn_GdipImageGetFrameDimensionsCount) + return false; + fn_GdipImageGetFrameDimensionsList = (GdipImageGetFrameDimensionsList_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameDimensionsList"); + if (!fn_GdipImageGetFrameDimensionsList) + return false; + fn_GdipImageGetFrameCount = (GdipImageGetFrameCount_Proc) + get_proc_addr (gdiplus_lib, "GdipImageGetFrameCount"); + if (!fn_GdipImageGetFrameCount) + return false; + fn_GdipImageSelectActiveFrame = (GdipImageSelectActiveFrame_Proc) + get_proc_addr (gdiplus_lib, "GdipImageSelectActiveFrame"); + if (!fn_GdipImageSelectActiveFrame) + return false; + fn_GdipCreateBitmapFromFile = (GdipCreateBitmapFromFile_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromFile"); + if (!fn_GdipCreateBitmapFromFile) + return false; + fn_GdipCreateBitmapFromStream = (GdipCreateBitmapFromStream_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateBitmapFromStream"); + if (!fn_GdipCreateBitmapFromStream) + return false; + fn_GdipCreateHBITMAPFromBitmap = (GdipCreateHBITMAPFromBitmap_Proc) + get_proc_addr (gdiplus_lib, "GdipCreateHBITMAPFromBitmap"); + if (!fn_GdipCreateHBITMAPFromBitmap) + return false; + fn_GdipDisposeImage = (GdipDisposeImage_Proc) + get_proc_addr (gdiplus_lib, "GdipDisposeImage"); + if (!fn_GdipDisposeImage) + return false; + fn_GdipGetImageHeight = (GdipGetImageHeight_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageHeight"); + if (!fn_GdipGetImageHeight) + return false; + fn_GdipGetImageWidth = (GdipGetImageWidth_Proc) + get_proc_addr (gdiplus_lib, "GdipGetImageWidth"); + if (!fn_GdipGetImageWidth) + return false; + /* LOAD_DLL_FN (shlwapi_lib, SHCreateMemStream); */ + + /* The following terrible kludge is required to use native image API + on Windows before Vista, because SHCreateMemStream was not + exported by name in those versions, only by ordinal number. */ + fn_SHCreateMemStream = (SHCreateMemStream_Proc) + get_proc_addr (shlwapi_lib, "SHCreateMemStream"); + if (!fn_SHCreateMemStream) + { + fn_SHCreateMemStream = (SHCreateMemStream_Proc) + get_proc_addr (shlwapi_lib, MAKEINTRESOURCEA (12)); + if (!fn_SHCreateMemStream) + return false; + } + + return true; +} + +# undef GdiplusStartup +# undef GdiplusShutdown +# undef GdipGetPropertyItemSize +# undef GdipGetPropertyItem +# undef GdipImageGetFrameDimensionsCount +# undef GdipImageGetFrameDimensionsList +# undef GdipImageGetFrameCount +# undef GdipImageSelectActiveFrame +# undef GdipCreateBitmapFromFile +# undef GdipCreateBitmapFromStream +# undef SHCreateMemStream +# undef GdipCreateHBITMAPFromBitmap +# undef GdipDisposeImage +# undef GdipGetImageHeight +# undef GdipGetImageWidth + +# define GdiplusStartup fn_GdiplusStartup +# define GdiplusShutdown fn_GdiplusShutdown +# define GdipGetPropertyItemSize fn_GdipGetPropertyItemSize +# define GdipGetPropertyItem fn_GdipGetPropertyItem +# define GdipImageGetFrameDimensionsCount fn_GdipImageGetFrameDimensionsCount +# define GdipImageGetFrameDimensionsList fn_GdipImageGetFrameDimensionsList +# define GdipImageGetFrameCount fn_GdipImageGetFrameCount +# define GdipImageSelectActiveFrame fn_GdipImageSelectActiveFrame +# define GdipCreateBitmapFromFile fn_GdipCreateBitmapFromFile +# define GdipCreateBitmapFromStream fn_GdipCreateBitmapFromStream +# define SHCreateMemStream fn_SHCreateMemStream +# define GdipCreateHBITMAPFromBitmap fn_GdipCreateHBITMAPFromBitmap +# define GdipDisposeImage fn_GdipDisposeImage +# define GdipGetImageHeight fn_GdipGetImageHeight +# define GdipGetImageWidth fn_GdipGetImageWidth + +#endif /* WINDOWSNT */ + +static int gdip_initialized; +static bool gdiplus_started; +static ULONG_PTR token; +static GdiplusStartupInput input; +static GdiplusStartupOutput output; + + +/* Initialize GDI+, return true if successful. */ +static bool +gdiplus_startup (void) +{ + GpStatus status; + + if (gdiplus_started) + return true; +#ifdef WINDOWSNT + if (!gdip_initialized) + gdip_initialized = gdiplus_init () ? 1 : -1; +#else + gdip_initialized = 1; +#endif + if (gdip_initialized > 0) + { + input.GdiplusVersion = 1; + input.DebugEventCallback = NULL; + input.SuppressBackgroundThread = FALSE; + input.SuppressExternalCodecs = FALSE; + + status = GdiplusStartup (&token, &input, &output); + if (status == Ok) + gdiplus_started = true; + return (status == Ok); + } + return false; +} + +/* This is called from term_ntproc. */ +void +w32_gdiplus_shutdown (void) +{ + if (gdiplus_started) + GdiplusShutdown (token); + gdiplus_started = false; +} + +bool +w32_can_use_native_image_api (Lisp_Object type) +{ + if (!w32_use_native_image_api) + return false; + if (!(EQ (type, Qjpeg) + || EQ (type, Qpng) + || EQ (type, Qgif) + || EQ (type, Qtiff) + || EQ (type, Qnative_image))) + { + /* GDI+ can also display BMP, Exif, ICON, WMF, and EMF images. + But we don't yet support these in image.c. */ + return false; + } + return gdiplus_startup (); +} + +enum PropertyItem_type { + PI_BYTE = 1, + PI_ASCIIZ = 2, + PI_USHORT = 3, + PI_ULONG = 4, + PI_ULONG_PAIR = 5, + PI_BYTE_ANY = 6, + PI_LONG = 7, + PI_LONG_PAIR = 10 +}; + +static double +decode_delay (PropertyItem *propertyItem, int frame) +{ + enum PropertyItem_type type = propertyItem[0].type; + unsigned long udelay; + double retval; + + switch (type) + { + case PI_BYTE: + case PI_BYTE_ANY: + udelay = ((unsigned char *)propertyItem[0].value)[frame]; + retval = udelay; + break; + case PI_USHORT: + udelay = ((unsigned short *)propertyItem[0].value)[frame]; + retval = udelay; + break; + case PI_ULONG: + case PI_LONG: /* delay should always be positive */ + udelay = ((unsigned long *)propertyItem[0].value)[frame]; + retval = udelay; + break; + default: + /* This negative value will cause the caller to disregard the + delay if we cannot determine it reliably. */ + add_to_log ("Invalid or unknown propertyItem type in w32image.c"); + retval = -1.0; + } + + return retval; +} + +static double +w32_frame_delay (GpBitmap *pBitmap, int frame) +{ + UINT size; + PropertyItem *propertyItem; + double delay = -1.0; + + /* Assume that the image has a property item of type PropertyItemEquipMake. + Get the size of that property item. This can fail for multi-frame TIFF + images. */ + GpStatus status = GdipGetPropertyItemSize (pBitmap, PropertyTagFrameDelay, + &size); + + if (status == Ok) + { + /* Allocate a buffer to receive the property item. */ + propertyItem = malloc (size); + if (propertyItem != NULL) + { + /* Get the property item. */ + GdipGetPropertyItem (pBitmap, PropertyTagFrameDelay, size, + propertyItem); + delay = decode_delay (propertyItem, frame); + if (delay <= 0) + { + /* In GIF files, unfortunately, delay is only specified + for the first frame. */ + delay = decode_delay (propertyItem, 0); + } + delay /= 100.0; + free (propertyItem); + } + } + return delay; +} + +static GpStatus +w32_select_active_frame (GpBitmap *pBitmap, int frame, int *nframes, + double *delay) +{ + UINT count, frameCount; + GUID pDimensionIDs[1]; + GpStatus status = Ok; + + status = GdipImageGetFrameDimensionsCount (pBitmap, &count); + frameCount = *nframes = 0; + *delay = -1.0; + if (count) + { + /* The following call will fill pDimensionIDs[0] with the + FrameDimensionTime GUID for GIF images, and + FrameDimensionPage GUID for other image types. Multi-page + GIF and TIFF images expect these values in the + GdipImageSelectActiveFrame call below. */ + status = GdipImageGetFrameDimensionsList (pBitmap, pDimensionIDs, 1); + status = GdipImageGetFrameCount (pBitmap, &pDimensionIDs[0], &frameCount); + if (status == Ok && frameCount > 1) + { + if (frame < 0 || frame >= frameCount) + status = GenericError; + else + { + status = GdipImageSelectActiveFrame (pBitmap, &pDimensionIDs[0], + frame); + *delay = w32_frame_delay (pBitmap, frame); + *nframes = frameCount; + } + } + } + return status; +} + +static ARGB +w32_image_bg_color (struct frame *f, struct image *img) +{ + Lisp_Object specified_bg = Fplist_get (XCDR (img->spec), QCbackground); + Emacs_Color color; + + /* If the user specified a color, try to use it; if not, use the + current frame background, ignoring any default background + color set by the image. */ + if (STRINGP (specified_bg) + ? w32_defined_color (f, SSDATA (specified_bg), &color, false, false) + : (w32_query_frame_background_color (f, &color), true)) + /* The user specified ':background', use that. */ + { + DWORD red = (((DWORD) color.red) & 0xff00) << 8; + DWORD green = ((DWORD) color.green) & 0xff00; + DWORD blue = ((DWORD) color.blue) >> 8; + return (ARGB) (red | green | blue); + } + return (ARGB) 0xff000000; +} + +int +w32_load_image (struct frame *f, struct image *img, + Lisp_Object spec_file, Lisp_Object spec_data) +{ + GpStatus status = GenericError; + GpBitmap *pBitmap; + Lisp_Object metadata; + + eassert (valid_image_p (img->spec)); + + /* This function only gets called if w32_gdiplus_startup was invoked + and succeeded. We have a valid token and GDI+ is active. */ + if (STRINGP (spec_file)) + { + const char *fn = map_w32_filename (SSDATA (spec_file), NULL); + wchar_t filename_w[MAX_PATH]; + filename_to_utf16 (fn, filename_w); + status = GdipCreateBitmapFromFile (filename_w, &pBitmap); + } + else if (STRINGP (spec_data)) + { + IStream *pStream = SHCreateMemStream ((BYTE *) SDATA (spec_data), + SBYTES (spec_data)); + if (pStream != NULL) + { + status = GdipCreateBitmapFromStream (pStream, &pBitmap); + IStream_Release (pStream); + } + } + + metadata = Qnil; + if (status == Ok) + { + /* In multiframe pictures, select the first frame. */ + Lisp_Object lisp_index = Fplist_get (XCDR (img->spec), QCindex); + int index = FIXNATP (lisp_index) ? XFIXNAT (lisp_index) : 0; + int nframes; + double delay; + status = w32_select_active_frame (pBitmap, index, &nframes, &delay); + if (status == Ok) + { + if (nframes > 1) + metadata = Fcons (Qcount, Fcons (make_fixnum (nframes), metadata)); + if (delay >= 0) + metadata = Fcons (Qdelay, Fcons (make_float (delay), metadata)); + } + } + + if (status == Ok) + { + ARGB bg_color = w32_image_bg_color (f, img); + Emacs_Pixmap pixmap; + + status = GdipCreateHBITMAPFromBitmap (pBitmap, &pixmap, bg_color); + if (status == Ok) + { + UINT width, height; + GdipGetImageWidth (pBitmap, &width); + GdipGetImageHeight (pBitmap, &height); + img->width = width; + img->height = height; + img->pixmap = pixmap; + img->lisp_data = metadata; + } + + GdipDisposeImage (pBitmap); + } + + if (status != Ok) + { + add_to_log ("Unable to load image %s", img->spec); + return 0; + } + return 1; +} diff --git a/src/w32proc.c b/src/w32proc.c index 62d7377130f..c50f246a454 100644 --- a/src/w32proc.c +++ b/src/w32proc.c @@ -3231,7 +3231,7 @@ such programs cannot be invoked by Emacs anyway. */) char *progname, progname_a[MAX_PATH]; program = Fexpand_file_name (program, Qnil); - encoded_progname = ENCODE_FILE (program); + encoded_progname = Fcopy_sequence (ENCODE_FILE (program)); progname = SSDATA (encoded_progname); unixtodos_filename (progname); filename_to_ansi (progname, progname_a); diff --git a/src/w32term.c b/src/w32term.c index 76cf6bd6964..1766b32514f 100644 --- a/src/w32term.c +++ b/src/w32term.c @@ -888,10 +888,10 @@ static void w32_draw_image_foreground_1 (struct glyph_string *, HBITMAP); static void w32_clear_glyph_string_rect (struct glyph_string *, int, int, int, int); static void w32_draw_relief_rect (struct frame *, int, int, int, int, - int, int, int, int, int, int, + int, int, int, int, int, int, int, RECT *); static void w32_draw_box_rect (struct glyph_string *, int, int, int, int, - int, bool, bool, RECT *); + int, int, bool, bool, RECT *); /* Set S->gc to a suitable GC for drawing glyph string S in cursor @@ -1101,19 +1101,28 @@ w32_set_glyph_string_clipping_exactly (struct glyph_string *src, static void w32_compute_glyph_string_overhangs (struct glyph_string *s) { - if (s->cmp == NULL - && s->first_glyph->type == CHAR_GLYPH - && !s->font_not_found_p) + if (s->cmp == NULL) { - struct font *font = s->font; struct font_metrics metrics; + if (s->first_glyph->type == CHAR_GLYPH && !s->font_not_found_p) + { + struct font *font = s->font; + font->driver->text_extents (font, s->char2b, s->nchars, &metrics); + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + } + else if (s->first_glyph->type == COMPOSITE_GLYPH) + { + Lisp_Object gstring = composition_gstring_from_id (s->cmp_id); - font->driver->text_extents (font, s->char2b, s->nchars, &metrics); - s->right_overhang = (metrics.rbearing > metrics.width - ? metrics.rbearing - metrics.width : 0); - s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + composition_gstring_width (gstring, s->cmp_from, s->cmp_to, &metrics); + s->right_overhang = (metrics.rbearing > metrics.width + ? metrics.rbearing - metrics.width : 0); + s->left_overhang = metrics.lbearing < 0 ? -metrics.lbearing : 0; + } } - else if (s->cmp) + else { s->right_overhang = s->cmp->rbearing - s->cmp->pixel_width; s->left_overhang = -s->cmp->lbearing; @@ -1160,7 +1169,7 @@ w32_draw_glyph_string_background (struct glyph_string *s, bool force_p) shouldn't be drawn in the first place. */ if (!s->background_filled_p) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); #if 0 /* TODO: stipple */ if (s->stippled_p) @@ -1206,7 +1215,7 @@ w32_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1264,7 +1273,7 @@ w32_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1361,7 +1370,7 @@ w32_draw_glyphless_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1529,7 +1538,7 @@ w32_query_colors (struct frame *f, Emacs_Color *colors, int ncolors) /* Store F's background color into *BGCOLOR. */ -static void +void w32_query_frame_background_color (struct frame *f, Emacs_Color *bgcolor) { bgcolor->pixel = FRAME_BACKGROUND_PIXEL (f); @@ -1617,7 +1626,7 @@ w32_setup_relief_colors (struct glyph_string *s) static void w32_draw_relief_rect (struct frame *f, int left_x, int top_y, int right_x, int bottom_y, - int width, int raised_p, + int hwidth, int vwidth, int raised_p, int top_p, int bot_p, int left_p, int right_p, RECT *clip_rect) { @@ -1634,14 +1643,14 @@ w32_draw_relief_rect (struct frame *f, /* Top. */ if (top_p) - for (i = 0; i < width; ++i) + for (i = 0; i < hwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i * left_p, top_y + i, right_x - left_x - i * (left_p + right_p ) + 1, 1); /* Left. */ if (left_p) - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i, top_y + (i + 1) * top_p, 1, bottom_y - top_y - (i + 1) * (bot_p + top_p) + 1); @@ -1653,14 +1662,14 @@ w32_draw_relief_rect (struct frame *f, /* Bottom. */ if (bot_p) - for (i = 0; i < width; ++i) + for (i = 0; i < hwidth; ++i) w32_fill_area (f, hdc, gc.foreground, left_x + i * left_p, bottom_y - i, right_x - left_x - i * (left_p + right_p) + 1, 1); /* Right. */ if (right_p) - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) w32_fill_area (f, hdc, gc.foreground, right_x - i, top_y + (i + 1) * top_p, 1, bottom_y - top_y - (i + 1) * (bot_p + top_p) + 1); @@ -1680,31 +1689,31 @@ w32_draw_relief_rect (struct frame *f, static void w32_draw_box_rect (struct glyph_string *s, - int left_x, int top_y, int right_x, int bottom_y, int width, - bool left_p, bool right_p, RECT *clip_rect) + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, RECT *clip_rect) { w32_set_clip_rectangle (s->hdc, clip_rect); /* Top. */ w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, top_y, right_x - left_x + 1, width); + left_x, top_y, right_x - left_x + 1, hwidth); /* Left. */ if (left_p) { w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, top_y, width, bottom_y - top_y + 1); + left_x, top_y, vwidth, bottom_y - top_y + 1); } /* Bottom. */ w32_fill_area (s->f, s->hdc, s->face->box_color, - left_x, bottom_y - width + 1, right_x - left_x + 1, width); + left_x, bottom_y - hwidth + 1, right_x - left_x + 1, hwidth); /* Right. */ if (right_p) { w32_fill_area (s->f, s->hdc, s->face->box_color, - right_x - width + 1, top_y, width, bottom_y - top_y + 1); + right_x - vwidth + 1, top_y, vwidth, bottom_y - top_y + 1); } w32_set_clip_rectangle (s->hdc, NULL); @@ -1716,7 +1725,7 @@ w32_draw_box_rect (struct glyph_string *s, static void w32_draw_glyph_string_box (struct glyph_string *s) { - int width, left_x, right_x, top_y, bottom_y, last_x; + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; bool left_p, right_p, raised_p; struct glyph *last_glyph; RECT clip_rect; @@ -1725,12 +1734,29 @@ w32_draw_glyph_string_box (struct glyph_string *s) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - /* The glyph that may have a right box line. */ - last_glyph = (s->cmp || s->img - ? s->first_glyph - : s->first_glyph + s->nchars - 1); + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; - width = eabs (s->face->box_line_width); + vwidth = eabs (s->face->box_vertical_line_width); + hwidth = eabs (s->face->box_horizontal_line_width); raised_p = s->face->box == FACE_RAISED_BOX; left_x = s->x; right_x = ((s->row->full_width_p && s->extends_to_end_of_line_p @@ -1751,13 +1777,13 @@ w32_draw_glyph_string_box (struct glyph_string *s) get_glyph_string_clip_rect (s, &clip_rect); if (s->face->box == FACE_SIMPLE_BOX) - w32_draw_box_rect (s, left_x, top_y, right_x, bottom_y, width, - left_p, right_p, &clip_rect); + w32_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); else { w32_setup_relief_colors (s); - w32_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, - width, raised_p, 1, 1, left_p, right_p, &clip_rect); + w32_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, 1, 1, left_p, right_p, &clip_rect); } } @@ -1795,7 +1821,7 @@ w32_draw_image_foreground (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -1982,7 +2008,7 @@ w32_draw_image_relief (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -2034,7 +2060,7 @@ w32_draw_image_relief (struct glyph_string *s) w32_setup_relief_colors (s); get_glyph_string_clip_rect (s, &r); - w32_draw_relief_rect (s->f, x, y, x1, y1, thick, raised_p, + w32_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, top_p, bot_p, left_p, right_p, &r); } @@ -2054,7 +2080,7 @@ w32_draw_image_foreground_1 (struct glyph_string *s, HBITMAP pixmap) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -2167,8 +2193,8 @@ static void w32_draw_image_glyph_string (struct glyph_string *s) { int x, y; - int box_line_hwidth = eabs (s->face->box_line_width); - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_hwidth = max (s->face->box_vertical_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int height, width; HBITMAP pixmap = 0; @@ -7657,6 +7683,25 @@ Windows 8. It is set to nil on Windows 9X. */); else w32_unicode_filenames = 1; + DEFVAR_BOOL ("w32-use-native-image-API", + w32_use_native_image_api, + doc: /* Non-nil means use the native MS-Windows image API to display images. + +A value of nil means displaying images other than PBM and XBM requires +optional supporting libraries to be installed. +The native image API library used is GDI+ via GDIPLUS.DLL. This +library is available only since W2K, therefore this variable is +unconditionally set to nil on older systems. */); + + /* For now, disabled by default, since this is an experimental feature. */ +#if 0 && HAVE_NATIVE_IMAGE_API + if (os_subtype == OS_9X) + w32_use_native_image_api = 0; + else + w32_use_native_image_api = 1; +#else + w32_use_native_image_api = 0; +#endif /* FIXME: The following variable will be (hopefully) removed before Emacs 25.1 gets released. */ diff --git a/src/w32term.h b/src/w32term.h index f8a8a727e8a..8ba248013c7 100644 --- a/src/w32term.h +++ b/src/w32term.h @@ -75,7 +75,6 @@ struct w32_palette_entry { extern void w32_regenerate_palette (struct frame *f); extern void w32_fullscreen_rect (HWND hwnd, int fsmode, RECT normal, RECT *rect); - /* For each display (currently only one on w32), we have a structure that records information about it. */ @@ -248,6 +247,8 @@ extern int w32_display_pixel_height (struct w32_display_info *); extern int w32_display_pixel_width (struct w32_display_info *); extern void initialize_frame_menubar (struct frame *); extern void w32_dialog_in_progress (Lisp_Object in_progress); +extern void w32_query_frame_background_color (struct frame *f, + Emacs_Color *bgcolor); extern void w32_make_frame_visible (struct frame *f); extern void w32_make_frame_invisible (struct frame *f); @@ -670,7 +671,8 @@ do { \ #define WM_EMACS_BRINGTOTOP (WM_EMACS_START + 23) #define WM_EMACS_INPUT_READY (WM_EMACS_START + 24) #define WM_EMACS_FILENOTIFY (WM_EMACS_START + 25) -#define WM_EMACS_END (WM_EMACS_START + 26) +#define WM_EMACS_IME_STATUS (WM_EMACS_START + 26) +#define WM_EMACS_END (WM_EMACS_START + 27) #define WND_FONTWIDTH_INDEX (0) #define WND_LINEHEIGHT_INDEX (4) diff --git a/src/window.c b/src/window.c index ff17cd88f38..e2dea8b70ef 100644 --- a/src/window.c +++ b/src/window.c @@ -1895,10 +1895,7 @@ POS, ROWH is the visible height of that row, and VPOS is the row number if (EQ (pos, Qt)) posint = -1; else if (!NILP (pos)) - { - CHECK_FIXNUM_COERCE_MARKER (pos); - posint = XFIXNUM (pos); - } + posint = fix_position (pos); else if (w == XWINDOW (selected_window)) posint = PT; else @@ -2111,30 +2108,20 @@ though when run from an idle timer with a delay of zero seconds. */) || window_outdated (w)) return Qnil; - if (NILP (first)) - row = (NILP (body) - ? MATRIX_ROW (w->current_matrix, 0) - : MATRIX_FIRST_TEXT_ROW (w->current_matrix)); - else if (FIXNUMP (first)) - { - CHECK_RANGED_INTEGER (first, 0, w->current_matrix->nrows); - row = MATRIX_ROW (w->current_matrix, XFIXNUM (first)); - } - else - error ("Invalid specification of first line"); - - if (NILP (last)) - - end_row = (NILP (body) - ? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows) - : MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w)); - else if (FIXNUMP (last)) - { - CHECK_RANGED_INTEGER (last, 0, w->current_matrix->nrows); - end_row = MATRIX_ROW (w->current_matrix, XFIXNUM (last)); - } - else - error ("Invalid specification of last line"); + row = (!NILP (first) + ? MATRIX_ROW (w->current_matrix, + check_integer_range (first, 0, + w->current_matrix->nrows)) + : NILP (body) + ? MATRIX_ROW (w->current_matrix, 0) + : MATRIX_FIRST_TEXT_ROW (w->current_matrix)); + end_row = (!NILP (last) + ? MATRIX_ROW (w->current_matrix, + check_integer_range (last, 0, + w->current_matrix->nrows)) + : NILP (body) + ? MATRIX_ROW (w->current_matrix, w->current_matrix->nrows) + : MATRIX_BOTTOM_TEXT_ROW (w->current_matrix, w)); while (row <= end_row && row->enabled_p && row->y + row->height < max_y) @@ -4328,11 +4315,11 @@ Note: This function does not operate on any child windows of WINDOW. */) EMACS_INT size_min = NILP (add) ? 0 : - XFIXNUM (w->new_pixel); EMACS_INT size_max = size_min + min (INT_MAX, MOST_POSITIVE_FIXNUM); - CHECK_RANGED_INTEGER (size, size_min, size_max); + int checked_size = check_integer_range (size, size_min, size_max); if (NILP (add)) wset_new_pixel (w, size); else - wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + XFIXNUM (size))); + wset_new_pixel (w, make_fixnum (XFIXNUM (w->new_pixel) + checked_size)); return w->new_pixel; } @@ -7509,8 +7496,7 @@ extract_dimension (Lisp_Object dimension) { if (NILP (dimension)) return -1; - CHECK_RANGED_INTEGER (dimension, 0, INT_MAX); - return XFIXNUM (dimension); + return check_integer_range (dimension, 0, INT_MAX); } static struct window * @@ -7976,19 +7962,17 @@ foreach_window_1 (struct window *w, bool (*fn) (struct window *, void *), /* Return true if window configurations CONFIGURATION1 and CONFIGURATION2 describe the same state of affairs. This is used by Fequal. - IGNORE_POSITIONS means ignore non-matching scroll positions - and the like. + Ignore non-matching scroll positions and the like. This ignores a couple of things like the dedication status of window, combination_limit and the like. This might have to be fixed. */ -bool +static bool compare_window_configurations (Lisp_Object configuration1, - Lisp_Object configuration2, - bool ignore_positions) + Lisp_Object configuration2) { - register struct save_window_data *d1, *d2; + struct save_window_data *d1, *d2; struct Lisp_Vector *sws1, *sws2; ptrdiff_t i; @@ -8006,9 +7990,6 @@ compare_window_configurations (Lisp_Object configuration1, || d1->frame_menu_bar_lines != d2->frame_menu_bar_lines || !EQ (d1->selected_frame, d2->selected_frame) || !EQ (d1->f_current_buffer, d2->f_current_buffer) - || (!ignore_positions - && (!EQ (d1->minibuf_scroll_window, d2->minibuf_scroll_window) - || !EQ (d1->minibuf_selected_window, d2->minibuf_selected_window))) || !EQ (d1->focus_frame, d2->focus_frame) /* Verify that the two configurations have the same number of windows. */ || sws1->header.size != sws2->header.size) @@ -8041,12 +8022,6 @@ compare_window_configurations (Lisp_Object configuration1, equality. */ || !EQ (sw1->parent, sw2->parent) || !EQ (sw1->prev, sw2->prev) - || (!ignore_positions - && (!EQ (sw1->hscroll, sw2->hscroll) - || !EQ (sw1->min_hscroll, sw2->min_hscroll) - || !EQ (sw1->start_at_line_beg, sw2->start_at_line_beg) - || NILP (Fequal (sw1->start, sw2->start)) - || NILP (Fequal (sw1->pointm, sw2->pointm)))) || !EQ (sw1->left_margin_cols, sw2->left_margin_cols) || !EQ (sw1->right_margin_cols, sw2->right_margin_cols) || !EQ (sw1->left_fringe_width, sw2->left_fringe_width) @@ -8071,7 +8046,7 @@ This function ignores details such as the values of point and scrolling positions. */) (Lisp_Object x, Lisp_Object y) { - if (compare_window_configurations (x, y, true)) + if (compare_window_configurations (x, y)) return Qt; return Qnil; } diff --git a/src/window.h b/src/window.h index aa8d2c8d1d2..167d1be7abb 100644 --- a/src/window.h +++ b/src/window.h @@ -1184,7 +1184,6 @@ extern Lisp_Object window_list (void); extern Lisp_Object window_parameter (struct window *, Lisp_Object parameter); extern struct window *decode_live_window (Lisp_Object); extern struct window *decode_any_window (Lisp_Object); -extern bool compare_window_configurations (Lisp_Object, Lisp_Object, bool); extern void mark_window_cursors_off (struct window *); extern bool window_wants_mode_line (struct window *); extern bool window_wants_header_line (struct window *); diff --git a/src/xdisp.c b/src/xdisp.c index a819f0aca38..eb7f3e7baa1 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -896,11 +896,6 @@ static struct props it_props[] = {0, 0, NULL} }; -/* Value is the position described by X. If X is a marker, value is - the marker_position of X. Otherwise, value is X. */ - -#define COERCE_MARKER(X) (MARKERP ((X)) ? Fmarker_position (X) : (X)) - /* Enumeration returned by some move_it_.* functions internally. */ enum move_it_result @@ -1101,6 +1096,7 @@ static Lisp_Object calc_line_height_property (struct it *, Lisp_Object, static void produce_special_glyphs (struct it *, enum display_element_type); static void show_mouse_face (Mouse_HLInfo *, enum draw_glyphs_face); static bool coords_in_mouse_face_p (struct window *, int, int); +static void reset_box_start_end_flags (struct it *); @@ -1419,6 +1415,7 @@ Value is the height in pixels of the line at point. */) set_buffer_internal_1 (XBUFFER (w->contents)); } SET_TEXT_POS (pt, PT, PT_BYTE); + void *itdata = bidi_shelve_cache (); start_display (&it, w, pt); /* Start from the beginning of the screen line, to make sure we traverse all of its display elements, and thus capture the @@ -1430,6 +1427,7 @@ Value is the height in pixels of the line at point. */) if (old_buffer) set_buffer_internal_1 (old_buffer); + bidi_unshelve_cache (itdata, false); return result; } @@ -1516,6 +1514,29 @@ window_hscroll_limited (struct window *w, struct frame *f) return window_hscroll; } +/* Reset the box-face start and end flags in the iterator. This is + called after producing glyphs, such that we reset these flags only + after producing a glyph with the flag set. */ + +static void +reset_box_start_end_flags (struct it *it) +{ + /* Don't reset if we've drawn the glyph in the display margins -- + those don't count as "produced glyphs". */ + if (it->area == TEXT_AREA + /* Don't reset if we displayed a fringe bitmap. */ + && !(it->what == IT_IMAGE && it->image_id < 0)) + { + /* Don't reset if the face is not a box face: that might mean we + are iterating some overlay or display string, and the first + character to have the box face is yet to be seen, when we pop + the iterator stack. */ + if (it->face_box_p) + it->start_of_box_run_p = false; + it->end_of_box_run_p = false; + } +} + /* Return true if position CHARPOS is visible in window W. CHARPOS < 0 means return info about WINDOW_END position. If visible, set *X and *Y to pixel coordinates of top left corner. @@ -1967,16 +1988,14 @@ pos_visible_p (struct window *w, ptrdiff_t charpos, int *x, int *y, /* Return the next character from STR. Return in *LEN the length of - the character. This is like STRING_CHAR_AND_LENGTH but never + the character. This is like string_char_and_length but never returns an invalid character. If we find one, we return a `?', but with the length of the invalid character. */ static int -string_char_and_length (const unsigned char *str, int *len) +check_char_and_length (const unsigned char *str, int *len) { - int c; - - c = STRING_CHAR_AND_LENGTH (str, *len); + int c = string_char_and_length (str, len); if (!CHAR_VALID_P (c)) /* We may not change the length here because other places in Emacs don't use this function, i.e. they silently accept invalid @@ -1999,11 +2018,10 @@ string_pos_nchars_ahead (struct text_pos pos, Lisp_Object string, ptrdiff_t ncha if (STRING_MULTIBYTE (string)) { const unsigned char *p = SDATA (string) + BYTEPOS (pos); - int len; while (nchars--) { - string_char_and_length (p, &len); + int len = BYTES_BY_CHAR_HEAD (*p); p += len; CHARPOS (pos) += 1; BYTEPOS (pos) += len; @@ -2044,12 +2062,10 @@ c_string_pos (ptrdiff_t charpos, const char *s, bool multibyte_p) if (multibyte_p) { - int len; - SET_TEXT_POS (pos, 0, 0); while (charpos--) { - string_char_and_length ((const unsigned char *) s, &len); + int len = BYTES_BY_CHAR_HEAD (*s); s += len; CHARPOS (pos) += 1; BYTEPOS (pos) += len; @@ -2073,12 +2089,11 @@ number_of_chars (const char *s, bool multibyte_p) if (multibyte_p) { ptrdiff_t rest = strlen (s); - int len; const unsigned char *p = (const unsigned char *) s; for (nchars = 0; rest > 0; ++nchars) { - string_char_and_length (p, &len); + int len = BYTES_BY_CHAR_HEAD (*p); rest -= len, p += len; } } @@ -2127,8 +2142,8 @@ estimate_mode_line_height (struct frame *f, enum face_id face_id) { if (face->font) height = normal_char_height (face->font, -1); - if (face->box_line_width > 0) - height += 2 * face->box_line_width; + if (face->box_horizontal_line_width > 0) + height += 2 * face->box_horizontal_line_width; } } @@ -3284,7 +3299,10 @@ init_iterator (struct it *it, struct window *w, with a left box line. */ face = FACE_FROM_ID_OR_NULL (it->f, remapped_base_face_id); if (face && face->box != FACE_NO_BOX) - it->start_of_box_run_p = true; + { + it->face_box_p = true; + it->start_of_box_run_p = true; + } } /* If a buffer position was specified, set the iterator there, @@ -3882,8 +3900,7 @@ compute_stop_pos (struct it *it) ptrdiff_t bpos = CHAR_TO_BYTE (pos); while (pos < endpos) { - int ch; - FETCH_CHAR_ADVANCE_NO_CHECK (ch, pos, bpos); + int ch = fetch_char_advance_no_check (&pos, &bpos); if (ch == ' ' || ch == '\t' || ch == '\n' || ch == '\f') { found = true; @@ -4400,8 +4417,11 @@ handle_face_prop (struct it *it) this is the start of a run of characters with box face, i.e. this character has a shadow on the left side. */ it->face_id = new_face_id; - it->start_of_box_run_p = (new_face->box != FACE_NO_BOX - && (old_face == NULL || !old_face->box)); + /* Don't reset the start_of_box_run_p flag, only set it if + needed. */ + if (!(it->start_of_box_run_p && old_face && old_face->box)) + it->start_of_box_run_p = (new_face->box != FACE_NO_BOX + && (old_face == NULL || !old_face->box)); it->face_box_p = new_face->box != FACE_NO_BOX; } @@ -4539,10 +4559,8 @@ face_before_or_after_it_pos (struct it *it, bool before_p) { struct text_pos pos1 = string_pos (charpos, it->string); const unsigned char *p = SDATA (it->string) + BYTEPOS (pos1); - int c, len; struct face *face = FACE_FROM_ID (it->f, face_id); - - c = string_char_and_length (p, &len); + int len, c = check_char_and_length (p, &len); face_id = FACE_FOR_CHAR (it->f, face, c, charpos, it->string); } } @@ -6542,7 +6560,16 @@ pop_it (struct it *it) it->object = p->u.stretch.object; break; case GET_FROM_BUFFER: - it->object = it->w->contents; + { + struct face *face = FACE_FROM_ID_OR_NULL (it->f, it->face_id); + + /* Restore the face_box_p flag, since it could have been + overwritten by the face of the object that we just finished + displaying. */ + if (face) + it->face_box_p = face->box != FACE_NO_BOX; + it->object = it->w->contents; + } break; case GET_FROM_STRING: { @@ -6628,7 +6655,7 @@ back_to_previous_line_start (struct it *it) { ptrdiff_t cp = IT_CHARPOS (*it), bp = IT_BYTEPOS (*it); - DEC_BOTH (cp, bp); + dec_both (&cp, &bp); IT_CHARPOS (*it) = find_newline_no_quit (cp, bp, -1, &IT_BYTEPOS (*it)); } @@ -7671,14 +7698,19 @@ get_next_display_element (struct it *it) /* If the box comes from face properties in a display string, check faces in that string. */ int string_face_id = face_after_it_pos (it); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, string_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, string_face_id)->box == FACE_NO_BOX) + it->end_of_box_run_p = true; } /* Otherwise, the box comes from the underlying face. If this is the last string character displayed, check the next buffer location. */ - else if ((IT_STRING_CHARPOS (*it) >= SCHARS (it->string) - 1) + else if (((IT_STRING_CHARPOS (*it) >= SCHARS (it->string) - 1) + /* For a composition, see if the string ends + at the last character included in the + composition. */ + || (it->what == IT_COMPOSITION + && (IT_STRING_CHARPOS (*it) + it->cmp_it.nchars + >= SCHARS (it->string)))) /* n_overlay_strings is unreliable unless overlay_string_index is non-negative. */ && ((it->current.overlay_string_index >= 0 @@ -7742,9 +7774,9 @@ get_next_display_element (struct it *it) CHARPOS (pos), 0, &ignore, face_id, false, 0); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, next_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, next_face_id)->box + == FACE_NO_BOX) + it->end_of_box_run_p = true; } } else if (CHARPOS (pos) >= ZV) @@ -7757,9 +7789,9 @@ get_next_display_element (struct it *it) CHARPOS (pos) + TEXT_PROP_DISTANCE_LIMIT, false, -1, 0); - it->end_of_box_run_p - = (FACE_FROM_ID (it->f, next_face_id)->box - == FACE_NO_BOX); + if (FACE_FROM_ID (it->f, next_face_id)->box + == FACE_NO_BOX) + it->end_of_box_run_p = true; } } } @@ -7769,9 +7801,9 @@ get_next_display_element (struct it *it) else if (it->method != GET_FROM_DISPLAY_VECTOR) { int face_id = face_after_it_pos (it); - it->end_of_box_run_p - = (face_id != it->face_id - && FACE_FROM_ID (it->f, face_id)->box == FACE_NO_BOX); + if (face_id != it->face_id + && FACE_FROM_ID (it->f, face_id)->box == FACE_NO_BOX) + it->end_of_box_run_p = true; } } /* If we reached the end of the object we've been iterating (e.g., a @@ -7808,10 +7840,6 @@ get_next_display_element (struct it *it) void set_iterator_to_next (struct it *it, bool reseat_p) { - /* Reset flags indicating start and end of a sequence of characters - with box. Reset them at the start of this function because - moving the iterator to a new position might set them. */ - it->start_of_box_run_p = it->end_of_box_run_p = false; switch (it->method) { @@ -8223,9 +8251,9 @@ next_element_from_display_vector (struct it *it) } } next_face = FACE_FROM_ID_OR_NULL (it->f, next_face_id); - it->end_of_box_run_p = (this_face && this_face->box != FACE_NO_BOX - && (!next_face - || next_face->box == FACE_NO_BOX)); + if (this_face && this_face->box != FACE_NO_BOX + && (!next_face || next_face->box == FACE_NO_BOX)) + it->end_of_box_run_p = true; it->face_box_p = this_face && this_face->box != FACE_NO_BOX; } else @@ -8447,7 +8475,7 @@ next_element_from_string (struct it *it) { const unsigned char *s = (SDATA (it->string) + IT_STRING_BYTEPOS (*it)); - it->c = string_char_and_length (s, &it->len); + it->c = check_char_and_length (s, &it->len); } else { @@ -8485,7 +8513,7 @@ next_element_from_string (struct it *it) { const unsigned char *s = (SDATA (it->string) + IT_STRING_BYTEPOS (*it)); - it->c = string_char_and_length (s, &it->len); + it->c = check_char_and_length (s, &it->len); } else { @@ -8543,7 +8571,7 @@ next_element_from_c_string (struct it *it) BYTEPOS (it->position) = CHARPOS (it->position) = -1; } else if (it->multibyte_p) - it->c = string_char_and_length (it->s + IT_BYTEPOS (*it), &it->len); + it->c = check_char_and_length (it->s + IT_BYTEPOS (*it), &it->len); else it->c = it->s[IT_BYTEPOS (*it)], it->len = 1; @@ -8658,7 +8686,7 @@ compute_stop_pos_backwards (struct it *it) position before that. This is called when we bump into a stop position while reordering bidirectional text. CHARPOS should be the last previously processed stop_pos (or BEGV/0, if none were - processed yet) whose position is less that IT's current + processed yet) whose position is less than IT's current position. */ static void @@ -8668,6 +8696,7 @@ handle_stop_backwards (struct it *it, ptrdiff_t charpos) ptrdiff_t where_we_are = (bufp ? IT_CHARPOS (*it) : IT_STRING_CHARPOS (*it)); struct display_pos save_current = it->current; struct text_pos save_position = it->position; + struct composition_it save_cmp_it = it->cmp_it; struct text_pos pos1; ptrdiff_t next_stop; @@ -8695,6 +8724,7 @@ handle_stop_backwards (struct it *it, ptrdiff_t charpos) it->bidi_p = true; it->current = save_current; it->position = save_position; + it->cmp_it = save_cmp_it; next_stop = it->stop_charpos; it->stop_charpos = it->prev_stop; handle_stop (it); @@ -8840,7 +8870,7 @@ next_element_from_buffer (struct it *it) /* Get the next character, maybe multibyte. */ p = BYTE_POS_ADDR (IT_BYTEPOS (*it)); if (it->multibyte_p && !ASCII_CHAR_P (*p)) - it->c = STRING_CHAR_AND_LENGTH (p, it->len); + it->c = string_char_and_length (p, &it->len); else it->c = *p, it->len = 1; @@ -9718,9 +9748,13 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos int line_height, line_start_x = 0, reached = 0; int max_current_x = 0; void *backup_data = NULL; + ptrdiff_t orig_charpos = -1; + enum it_method orig_method = NUM_IT_METHODS; for (;;) { + orig_charpos = IT_CHARPOS (*it); + orig_method = it->method; if (op & MOVE_TO_VPOS) { /* If no TO_CHARPOS and no TO_X specified, stop at the @@ -9954,7 +9988,21 @@ move_it_to (struct it *it, ptrdiff_t to_charpos, int to_x, int to_y, int to_vpos } } else - it->continuation_lines_width += it->current_x; + { + /* Make sure we do advance, otherwise we might infloop. + This could happen when the first display element is + wider than the window, or if we have a wrap-prefix + that doesn't leave enough space after it to display + even a single character. We only do this for moving + through buffer text, as with display/overlay strings + we'd need to also compare it->object's, and this is + unlikely to happen in that case anyway. */ + if (IT_CHARPOS (*it) == orig_charpos + && it->method == orig_method + && orig_method == GET_FROM_BUFFER) + set_iterator_to_next (it, false); + it->continuation_lines_width += it->current_x; + } break; default: @@ -10115,7 +10163,7 @@ move_it_vertically_backward (struct it *it, int dy) { ptrdiff_t cp = IT_CHARPOS (*it), bp = IT_BYTEPOS (*it); - DEC_BOTH (cp, bp); + dec_both (&cp, &bp); cp = find_newline_no_quit (cp, bp, -1, NULL); move_it_to (it, cp, -1, -1, -1, MOVE_TO_POS); } @@ -10481,13 +10529,13 @@ include the height of both, if present, in the return value. */) bpos = BEGV_BYTE; while (bpos < ZV_BYTE) { - FETCH_CHAR_ADVANCE (c, start, bpos); + c = fetch_char_advance (&start, &bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) break; } while (bpos > BEGV_BYTE) { - DEC_BOTH (start, bpos); + dec_both (&start, &bpos); c = FETCH_CHAR (bpos); if (!(c == ' ' || c == '\t')) break; @@ -10495,8 +10543,7 @@ include the height of both, if present, in the return value. */) } else { - CHECK_FIXNUM_COERCE_MARKER (from); - start = min (max (XFIXNUM (from), BEGV), ZV); + start = clip_to_bounds (BEGV, fix_position (from), ZV); bpos = CHAR_TO_BYTE (start); } @@ -10510,23 +10557,20 @@ include the height of both, if present, in the return value. */) bpos = ZV_BYTE; while (bpos > BEGV_BYTE) { - DEC_BOTH (end, bpos); + dec_both (&end, &bpos); c = FETCH_CHAR (bpos); if (!(c == ' ' || c == '\t' || c == '\n' || c == '\r')) break; } while (bpos < ZV_BYTE) { - FETCH_CHAR_ADVANCE (c, end, bpos); + c = fetch_char_advance (&end, &bpos); if (!(c == ' ' || c == '\t')) break; } } else - { - CHECK_FIXNUM_COERCE_MARKER (to); - end = max (start, min (XFIXNUM (to), ZV)); - } + end = clip_to_bounds (start, fix_position (to), ZV); if (!NILP (x_limit) && RANGED_FIXNUMP (0, x_limit, INT_MAX)) max_x = XFIXNUM (x_limit); @@ -10748,32 +10792,26 @@ message_dolog (const char *m, ptrdiff_t nbytes, bool nlflag, bool multibyte) if (multibyte && NILP (BVAR (current_buffer, enable_multibyte_characters))) { - ptrdiff_t i; - int c, char_bytes; - char work[1]; - /* Convert a multibyte string to single-byte for the *Message* buffer. */ - for (i = 0; i < nbytes; i += char_bytes) + for (ptrdiff_t i = 0; i < nbytes; ) { - c = string_char_and_length (msg + i, &char_bytes); - work[0] = CHAR_TO_BYTE8 (c); - insert_1_both (work, 1, 1, true, false, false); + int char_bytes, c = check_char_and_length (msg + i, &char_bytes); + char work = CHAR_TO_BYTE8 (c); + insert_1_both (&work, 1, 1, true, false, false); + i += char_bytes; } } else if (! multibyte && ! NILP (BVAR (current_buffer, enable_multibyte_characters))) { - ptrdiff_t i; - int c, char_bytes; - unsigned char str[MAX_MULTIBYTE_LENGTH]; /* Convert a single-byte string to multibyte for the *Message* buffer. */ - for (i = 0; i < nbytes; i++) + for (ptrdiff_t i = 0; i < nbytes; i++) { - c = msg[i]; - MAKE_CHAR_MULTIBYTE (c); - char_bytes = CHAR_STRING (c, str); + int c = make_char_multibyte (msg[i]); + unsigned char str[MAX_MULTIBYTE_LENGTH]; + int char_bytes = CHAR_STRING (c, str); insert_1_both ((char *) str, 1, char_bytes, true, false, false); } } @@ -12527,7 +12565,6 @@ prepare_menu_bars (void) continue; if (!FRAME_TOOLTIP_P (f) - && !FRAME_PARENT_FRAME (f) && (FRAME_ICONIFIED_P (f) || FRAME_VISIBLE_P (f) == 1 /* Exclude TTY frames that are obscured because they @@ -12573,10 +12610,9 @@ prepare_menu_bars (void) && !XBUFFER (w->contents)->text->redisplay) continue; - if (FRAME_PARENT_FRAME (f)) - continue; + if (!FRAME_PARENT_FRAME (f)) + menu_bar_hooks_run = update_menu_bar (f, false, menu_bar_hooks_run); - menu_bar_hooks_run = update_menu_bar (f, false, menu_bar_hooks_run); update_tab_bar (f, false); #ifdef HAVE_WINDOW_SYSTEM update_tool_bar (f, false); @@ -12588,7 +12624,10 @@ prepare_menu_bars (void) else { struct frame *sf = SELECTED_FRAME (); - update_menu_bar (sf, true, false); + + if (!FRAME_PARENT_FRAME (sf)) + update_menu_bar (sf, true, false); + update_tab_bar (sf, true); #ifdef HAVE_WINDOW_SYSTEM update_tool_bar (sf, true); @@ -13478,11 +13517,6 @@ handle_tab_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event.kind = TAB_BAR_EVENT; event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - - event.kind = TAB_BAR_EVENT; - event.frame_or_window = frame; event.arg = key; event.modifiers = close_p ? ctrl_modifier | modifiers : modifiers; kbd_buffer_store_event (&event); @@ -13658,11 +13692,6 @@ tty_handle_tab_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event->kind = TAB_BAR_EVENT; event->frame_or_window = frame; - event->arg = frame; - kbd_buffer_store_event (event); - - event->kind = TAB_BAR_EVENT; - event->frame_or_window = frame; event->arg = key; if (close_p) event->modifiers |= ctrl_modifier; @@ -14444,11 +14473,6 @@ handle_tool_bar_click (struct frame *f, int x, int y, bool down_p, XSETFRAME (frame, f); event.kind = TOOL_BAR_EVENT; event.frame_or_window = frame; - event.arg = frame; - kbd_buffer_store_event (&event); - - event.kind = TOOL_BAR_EVENT; - event.frame_or_window = frame; event.arg = key; event.modifiers = modifiers; kbd_buffer_store_event (&event); @@ -15048,7 +15072,7 @@ overlay_arrows_changed_p (bool set_redisplay) val = find_symbol_value (var); if (!MARKERP (val)) continue; - if (! EQ (COERCE_MARKER (val), + if (! EQ (Fmarker_position (val), /* FIXME: Don't we have a problem, using such a global * "last-position" if the variable is buffer-local? */ Fget (var, Qlast_arrow_position)) @@ -15091,8 +15115,7 @@ update_overlay_arrows (int up_to_date) Lisp_Object val = find_symbol_value (var); if (!MARKERP (val)) continue; - Fput (var, Qlast_arrow_position, - COERCE_MARKER (val)); + Fput (var, Qlast_arrow_position, Fmarker_position (val)); Fput (var, Qlast_arrow_string, overlay_arrow_string_or_property (var)); } @@ -15563,6 +15586,12 @@ redisplay_internal (void) if (it.current_x != this_line_start_x) goto cancel; + /* Give up on this optimization if the line starts with a + string with display property that draws on the fringes, + as that might interfere with line-prefix display. */ + if (it.sp > 1 + && it.method == GET_FROM_IMAGE && it.image_id == -1) + goto cancel; redisplay_trace ("trying display optimization 1\n"); w->cursor.vpos = -1; overlay_arrow_seen = false; @@ -20335,6 +20364,12 @@ try_window_id (struct window *w) if (! init_to_row_end (&it, w, last_unchanged_at_beg_row)) GIVE_UP (18); + /* Give up if the row starts with a display property that draws + on the fringes, since that could prevent correct display of + line-prefix and wrap-prefix. */ + if (it.sp > 1 + && it.method == GET_FROM_IMAGE && it.image_id == -1) + GIVE_UP (26); start_pos = it.current.pos; /* Start displaying new lines in the desired matrix at the same @@ -21250,7 +21285,7 @@ get_overlay_arrow_glyph_row (struct window *w, Lisp_Object overlay_arrow_string) /* Get the next character. */ if (multibyte_p) - it.c = it.char_to_display = string_char_and_length (p, &it.len); + it.c = it.char_to_display = check_char_and_length (p, &it.len); else { it.c = it.char_to_display = *p, it.len = 1; @@ -21620,6 +21655,8 @@ append_space_for_newline (struct it *it, bool default_face_p) const int indicator_column = fill_column_indicator_column (it, char_width); + int saved_end_of_box_run = it->end_of_box_run_p; + bool should_keep_end_of_box_run = false; if (it->current_x == indicator_column) { @@ -21642,14 +21679,18 @@ append_space_for_newline (struct it *it, bool default_face_p) have the end_of_box_run_p flag set for it, so there's no need for the appended newline glyph to have that flag set. */ - if (it->glyph_row->reversed_p - /* But if the appended newline glyph goes all the way to - the end of the row, there will be no stretch glyph, - so leave the box flag set. */ - && saved_x + FRAME_COLUMN_WIDTH (it->f) < it->last_visible_x) - it->end_of_box_run_p = false; + if (!(it->glyph_row->reversed_p + /* But if the appended newline glyph goes all the way to + the end of the row, there will be no stretch glyph, + so leave the box flag set. */ + && saved_x + FRAME_COLUMN_WIDTH (it->f) < it->last_visible_x)) + should_keep_end_of_box_run = true; } PRODUCE_GLYPHS (it); + /* Restore the end_of_box_run_p flag which was reset by + PRODUCE_GLYPHS. */ + if (should_keep_end_of_box_run) + it->end_of_box_run_p = saved_end_of_box_run; #ifdef HAVE_WINDOW_SYSTEM if (FRAME_WINDOW_P (it->f)) { @@ -22597,7 +22638,7 @@ find_row_edges (struct it *it, struct glyph_row *row, required when scanning back, because max_pos will already have a much larger value. */ if (CHARPOS (row->end.pos) > max_pos) - INC_BOTH (max_pos, max_bpos); + inc_both (&max_pos, &max_bpos); SET_TEXT_POS (row->maxpos, max_pos, max_bpos); } else if (CHARPOS (it->eol_pos) > 0) @@ -22615,7 +22656,7 @@ find_row_edges (struct it *it, struct glyph_row *row, SET_TEXT_POS (row->maxpos, max_pos, max_bpos); else { - INC_BOTH (max_pos, max_bpos); + inc_both (&max_pos, &max_bpos); SET_TEXT_POS (row->maxpos, max_pos, max_bpos); } } @@ -24025,7 +24066,7 @@ See also `bidi-paragraph-direction'. */) to make sure we are within that paragraph. To that end, find the previous non-empty line. */ if (pos >= ZV && pos > BEGV) - DEC_BOTH (pos, bytepos); + dec_both (&pos, &bytepos); AUTO_STRING (trailing_white_space, "[\f\t ]*\n"); if (fast_looking_at (trailing_white_space, pos, bytepos, ZV, ZV_BYTE, Qnil) > 0) @@ -24421,6 +24462,7 @@ Value is the new character position of point. */) bool at_eol_p; bool overshoot_expected = false; bool target_is_eol_p = false; + void *itdata = bidi_shelve_cache (); /* Setup the arena. */ SET_TEXT_POS (pt, PT, PT_BYTE); @@ -24649,6 +24691,7 @@ Value is the new character position of point. */) /* Move point to that position. */ SET_PT_BOTH (IT_CHARPOS (it), IT_BYTEPOS (it)); + bidi_unshelve_cache (itdata, false); } return make_fixnum (PT); @@ -27676,22 +27719,32 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, struct glyph *glyph, *last; Lisp_Object lgstring; int i; + bool glyph_not_available_p; s->for_overlaps = overlaps; glyph = s->row->glyphs[s->area] + start; last = s->row->glyphs[s->area] + end; + glyph_not_available_p = glyph->glyph_not_available_p; s->cmp_id = glyph->u.cmp.id; s->cmp_from = glyph->slice.cmp.from; s->cmp_to = glyph->slice.cmp.to + 1; s->face = FACE_FROM_ID (s->f, face_id); lgstring = composition_gstring_from_id (s->cmp_id); s->font = XFONT_OBJECT (LGSTRING_FONT (lgstring)); + /* The width of a composition glyph string is the sum of the + composition's glyph widths. */ + s->width = s->first_glyph->pixel_width; glyph++; while (glyph < last && glyph->u.cmp.automatic && glyph->u.cmp.id == s->cmp_id - && s->cmp_to == glyph->slice.cmp.from) - s->cmp_to = (glyph++)->slice.cmp.to + 1; + && glyph->face_id == face_id + && s->cmp_to == glyph->slice.cmp.from + && glyph->glyph_not_available_p == glyph_not_available_p) + { + s->width += glyph->pixel_width; + s->cmp_to = (glyph++)->slice.cmp.to + 1; + } for (i = s->cmp_from; i < s->cmp_to; i++) { @@ -27701,7 +27754,13 @@ fill_gstring_glyph_string (struct glyph_string *s, int face_id, /* Ensure that the code is only 2 bytes wide. */ s->char2b[i] = code & 0xFFFF; } - s->width = composition_gstring_width (lgstring, s->cmp_from, s->cmp_to, NULL); + + /* If the specified font could not be loaded, record that fact in + S->font_not_found_p so that we can draw rectangles for the + characters of the glyph string. */ + if (glyph_not_available_p) + s->font_not_found_p = true; + return glyph - s->row->glyphs[s->area]; } @@ -28898,7 +28957,7 @@ append_composite_glyph (struct it *it) glyph->overlaps_vertically_p = (it->phys_ascent > it->ascent || it->phys_descent > it->descent); glyph->padding_p = false; - glyph->glyph_not_available_p = false; + glyph->glyph_not_available_p = it->glyph_not_available_p; glyph->face_id = it->face_id; glyph->font_type = FONT_TYPE_UNKNOWN; if (it->bidi_p) @@ -29026,18 +29085,21 @@ produce_image_glyph (struct it *it) if (face->box != FACE_NO_BOX) { - if (face->box_line_width > 0) + if (face->box_horizontal_line_width > 0) { if (slice.y == 0) - it->ascent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; if (slice.y + slice.height == img->height) - it->descent += face->box_line_width; + it->descent += face->box_horizontal_line_width; } - if (it->start_of_box_run_p && slice.x == 0) - it->pixel_width += eabs (face->box_line_width); - if (it->end_of_box_run_p && slice.x + slice.width == img->width) - it->pixel_width += eabs (face->box_line_width); + if (face->box_vertical_line_width > 0) + { + if (it->start_of_box_run_p && slice.x == 0) + it->pixel_width += face->box_vertical_line_width; + if (it->end_of_box_run_p && slice.x + slice.width == img->width) + it->pixel_width += face->box_vertical_line_width; + } } take_vertical_position_into_account (it); @@ -29135,15 +29197,18 @@ produce_xwidget_glyph (struct it *it) if (face->box != FACE_NO_BOX) { - if (face->box_line_width > 0) + if (face->box_horizontal_line_width > 0) { - it->ascent += face->box_line_width; - it->descent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; + it->descent += face->box_horizontal_line_width; } - if (it->start_of_box_run_p) - it->pixel_width += eabs (face->box_line_width); - it->pixel_width += eabs (face->box_line_width); + if (face->box_vertical_line_width > 0) + { + if (it->start_of_box_run_p) + it->pixel_width += face->box_vertical_line_width; + it->pixel_width += face->box_vertical_line_width; + } } take_vertical_position_into_account (it); @@ -29366,7 +29431,7 @@ produce_stretch_glyph (struct it *it) /* Compute the width of the stretch. */ if ((prop = Fplist_get (plist, QCwidth), !NILP (prop)) - && calc_pixel_width_or_height (&tem, it, prop, font, true, 0)) + && calc_pixel_width_or_height (&tem, it, prop, font, true, NULL)) { /* Absolute width `:width WIDTH' specified and valid. */ zero_width_ok_p = true; @@ -29382,7 +29447,7 @@ produce_stretch_glyph (struct it *it) it2 = *it; if (it->multibyte_p) - it2.c = it2.char_to_display = STRING_CHAR_AND_LENGTH (p, it2.len); + it2.c = it2.char_to_display = string_char_and_length (p, &it2.len); else { it2.c = it2.char_to_display = *p, it2.len = 1; @@ -29422,7 +29487,7 @@ produce_stretch_glyph (struct it *it) int default_height = normal_char_height (font, ' '); if ((prop = Fplist_get (plist, QCheight), !NILP (prop)) - && calc_pixel_width_or_height (&tem, it, prop, font, false, 0)) + && calc_pixel_width_or_height (&tem, it, prop, font, false, NULL)) { height = (int)tem; zero_height_ok_p = true; @@ -29906,6 +29971,31 @@ produce_glyphless_glyph (struct it *it, bool for_no_font, Lisp_Object acronym) } +/* If face has a box, add the box thickness to the character + height. If character has a box line to the left and/or + right, add the box line width to the character's width. */ +#define IT_APPLY_FACE_BOX(it, face) \ + do { \ + if (face->box != FACE_NO_BOX) \ + { \ + int thick = face->box_horizontal_line_width; \ + if (thick > 0) \ + { \ + it->ascent += thick; \ + it->descent += thick; \ + } \ + \ + thick = face->box_vertical_line_width; \ + if (thick > 0) \ + { \ + if (it->start_of_box_run_p) \ + it->pixel_width += thick; \ + if (it->end_of_box_run_p) \ + it->pixel_width += thick; \ + } \ + } \ + } while (false) + /* RIF: Produce glyphs/get display metrics for the display element IT is loaded with. See the description of struct it in dispextern.h @@ -30021,26 +30111,7 @@ gui_produce_glyphs (struct it *it) if (stretched_p) it->pixel_width *= XFLOATINT (it->space_width); - /* If face has a box, add the box thickness to the character - height. If character has a box line to the left and/or - right, add the box line width to the character's width. */ - if (face->box != FACE_NO_BOX) - { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = -thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; - } + IT_APPLY_FACE_BOX(it, face); /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ @@ -30155,10 +30226,10 @@ gui_produce_glyphs (struct it *it) if ((it->max_ascent > 0 || it->max_descent > 0) && face->box != FACE_NO_BOX - && face->box_line_width > 0) + && face->box_horizontal_line_width > 0) { - it->ascent += face->box_line_width; - it->descent += face->box_line_width; + it->ascent += face->box_horizontal_line_width; + it->descent += face->box_horizontal_line_width; } if (!NILP (height) && XFIXNUM (height) > it->ascent + it->descent) @@ -30565,23 +30636,7 @@ gui_produce_glyphs (struct it *it) it->pixel_width = cmp->pixel_width; it->ascent = it->phys_ascent = cmp->ascent; it->descent = it->phys_descent = cmp->descent; - if (face->box != FACE_NO_BOX) - { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = - thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; - } + IT_APPLY_FACE_BOX(it, face); /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ @@ -30610,28 +30665,23 @@ gui_produce_glyphs (struct it *it) it->pixel_width = composition_gstring_width (gstring, it->cmp_it.from, it->cmp_it.to, &metrics); - if (it->glyph_row - && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) - it->glyph_row->contains_overlapping_glyphs_p = true; - it->ascent = it->phys_ascent = metrics.ascent; - it->descent = it->phys_descent = metrics.descent; - if (face->box != FACE_NO_BOX) + if (it->pixel_width == 0) { - int thick = face->box_line_width; - - if (thick > 0) - { - it->ascent += thick; - it->descent += thick; - } - else - thick = - thick; - - if (it->start_of_box_run_p) - it->pixel_width += thick; - if (it->end_of_box_run_p) - it->pixel_width += thick; + it->glyph_not_available_p = true; + it->phys_ascent = it->ascent; + it->phys_descent = it->descent; + it->pixel_width = face->font->space_width; } + else + { + if (it->glyph_row + && (metrics.lbearing < 0 || metrics.rbearing > metrics.width)) + it->glyph_row->contains_overlapping_glyphs_p = true; + it->ascent = it->phys_ascent = metrics.ascent; + it->descent = it->phys_descent = metrics.descent; + } + IT_APPLY_FACE_BOX(it, face); + /* If face has an overline, add the height of the overline (1 pixel) and a 1 pixel margin to the character height. */ if (face->overline_p) @@ -30877,14 +30927,6 @@ get_specified_cursor_type (Lisp_Object arg, int *width) return BAR_CURSOR; } - if (CONSP (arg) - && EQ (XCAR (arg), Qbar) - && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) - { - *width = XFIXNUM (XCDR (arg)); - return BAR_CURSOR; - } - if (EQ (arg, Qhbar)) { *width = 2; @@ -30892,11 +30934,16 @@ get_specified_cursor_type (Lisp_Object arg, int *width) } if (CONSP (arg) - && EQ (XCAR (arg), Qhbar) && RANGED_FIXNUMP (0, XCDR (arg), INT_MAX)) { *width = XFIXNUM (XCDR (arg)); - return HBAR_CURSOR; + + if (EQ (XCAR (arg), Qbox)) + return FILLED_BOX_CURSOR; + else if (EQ (XCAR (arg), Qbar)) + return BAR_CURSOR; + else if (EQ (XCAR (arg), Qhbar)) + return HBAR_CURSOR; } /* Treat anything unknown as "hollow box cursor". @@ -31023,23 +31070,28 @@ get_window_cursor_type (struct window *w, struct glyph *glyph, int *width, if (!w->cursor_off_p) { if (glyph != NULL && glyph->type == XWIDGET_GLYPH) - return NO_CURSOR; + return NO_CURSOR; if (glyph != NULL && glyph->type == IMAGE_GLYPH) { if (cursor_type == FILLED_BOX_CURSOR) { - /* Using a block cursor on large images can be very annoying. - So use a hollow cursor for "large" images. - If image is not transparent (no mask), also use hollow cursor. */ + /* Using a block cursor on large images can be very + annoying. So use a hollow cursor for "large" images. + If image is not transparent (no mask), also use + hollow cursor. */ struct image *img = IMAGE_OPT_FROM_ID (f, glyph->u.img_id); if (img != NULL && IMAGEP (img->spec)) { - /* Arbitrarily, interpret "Large" as >32x32 and >NxN - where N = size of default frame font size. - This should cover most of the "tiny" icons people may use. */ + /* Interpret "large" as >SIZExSIZE and >NxN where + SIZE is the value from cursor-type of the form + (box . SIZE), where N = size of default frame + font size. So, setting cursor-type to (box . 32) + should cover most of the "tiny" icons people may + use. */ if (!img->mask - || img->width > max (32, WINDOW_FRAME_COLUMN_WIDTH (w)) - || img->height > max (32, WINDOW_FRAME_LINE_HEIGHT (w))) + || (CONSP (BVAR (b, cursor_type)) + && img->width > max (*width, WINDOW_FRAME_COLUMN_WIDTH (w)) + && img->height > max (*width, WINDOW_FRAME_LINE_HEIGHT (w)))) cursor_type = HOLLOW_BOX_CURSOR; } } diff --git a/src/xfaces.c b/src/xfaces.c index 711ec48bbdd..c4a4e1c94f3 100644 --- a/src/xfaces.c +++ b/src/xfaces.c @@ -220,6 +220,7 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include "sysstdio.h" #include <sys/types.h> #include <sys/stat.h> +#include <math.h> #include "lisp.h" #include "character.h" @@ -819,6 +820,128 @@ load_pixmap (struct frame *f, Lisp_Object name) Color Handling ***********************************************************************/ +/* Parse hex color component specification that starts at S and ends + right before E. Set *DST to the parsed value normalized so that + the maximum value for the number of hex digits given becomes 65535, + and return true on success, false otherwise. */ +static bool +parse_hex_color_comp (const char *s, const char *e, unsigned short *dst) +{ + int n = e - s; + if (n <= 0 || n > 4) + return false; + int val = 0; + for (; s < e; s++) + { + int digit; + if (*s >= '0' && *s <= '9') + digit = *s - '0'; + else if (*s >= 'A' && *s <= 'F') + digit = *s - 'A' + 10; + else if (*s >= 'a' && *s <= 'f') + digit = *s - 'a' + 10; + else + return false; + val = (val << 4) | digit; + } + int maxval = (1 << (n * 4)) - 1; + *dst = (unsigned)val * 65535 / maxval; + return true; +} + +/* Parse floating-point color component specification that starts at S + and ends right before E. Return the parsed number if in the range + [0,1]; otherwise return -1. */ +static double +parse_float_color_comp (const char *s, const char *e) +{ + char *end; + double x = strtod (s, &end); + return (end == e && x >= 0 && x <= 1) ? x : -1; +} + +/* Parse SPEC as a numeric color specification and set *R, *G and *B. + Return true on success, false on failure. + + Recognized formats of SPEC: + + "#RGB", with R, G and B hex strings of equal length, 1-4 digits each. + "rgb:R/G/B", with R, G and B hex strings, 1-4 digits each. + "rgbi:R/G/B", with R, G and B numbers in [0,1]. + + If the function succeeds, it assigns to each of the components *R, + *G, and *B a value normalized to be in the [0, 65535] range. If + the function fails, some or all of the components remain unassigned. */ +bool +parse_color_spec (const char *spec, + unsigned short *r, unsigned short *g, unsigned short *b) +{ + int len = strlen (spec); + if (spec[0] == '#') + { + if ((len - 1) % 3 == 0) + { + int n = (len - 1) / 3; + return ( parse_hex_color_comp (spec + 1 + 0 * n, + spec + 1 + 1 * n, r) + && parse_hex_color_comp (spec + 1 + 1 * n, + spec + 1 + 2 * n, g) + && parse_hex_color_comp (spec + 1 + 2 * n, + spec + 1 + 3 * n, b)); + } + } + else if (strncmp (spec, "rgb:", 4) == 0) + { + char *sep1, *sep2; + return ((sep1 = strchr (spec + 4, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && parse_hex_color_comp (spec + 4, sep1, r) + && parse_hex_color_comp (sep1 + 1, sep2, g) + && parse_hex_color_comp (sep2 + 1, spec + len, b)); + } + else if (strncmp (spec, "rgbi:", 5) == 0) + { + char *sep1, *sep2; + double red, green, blue; + if ((sep1 = strchr (spec + 5, '/')) != NULL + && (sep2 = strchr (sep1 + 1, '/')) != NULL + && (red = parse_float_color_comp (spec + 5, sep1)) >= 0 + && (green = parse_float_color_comp (sep1 + 1, sep2)) >= 0 + && (blue = parse_float_color_comp (sep2 + 1, spec + len)) >= 0) + { + *r = lrint (red * 65535); + *g = lrint (green * 65535); + *b = lrint (blue * 65535); + return true; + } + } + return false; +} + +DEFUN ("color-values-from-color-spec", + Fcolor_values_from_color_spec, + Scolor_values_from_color_spec, + 1, 1, 0, + doc: /* Parse color SPEC as a numeric color and return (RED GREEN BLUE). +This function recognises the following formats for SPEC: + + #RGB, where R, G and B are hex numbers of equal length, 1-4 digits each. + rgb:R/G/B, where R, G, and B are hex numbers, 1-4 digits each. + rgbi:R/G/B, where R, G and B are floating-point numbers in [0,1]. + +If SPEC is not in one of the above forms, return nil. + +Each of the 3 integer members of the resulting list, RED, GREEN, and BLUE, +is normalized to have its value in [0,65535]. */) + (Lisp_Object spec) +{ + CHECK_STRING (spec); + unsigned short r, g, b; + return (parse_color_spec (SSDATA (spec), &r, &g, &b) + ? list3i (r, g, b) + : Qnil); +} + /* Parse RGB_LIST, and fill in the RGB fields of COLOR. RGB_LIST should contain (at least) 3 lisp integers. Return true iff RGB_LIST is OK. */ @@ -1888,7 +2011,7 @@ get_lface_attributes_no_remap (struct frame *f, Lisp_Object face_name, lface = lface_from_face_name_no_resolve (f, face_name, signal_p); if (! NILP (lface)) - memcpy (attrs, XVECTOR (lface)->contents, + memcpy (attrs, xvector_contents (lface), LFACE_VECTOR_SIZE * sizeof *attrs); return !NILP (lface); @@ -2860,7 +2983,7 @@ The value is TO. */) f = XFRAME (new_frame); } - vcopy (copy, 0, XVECTOR (lface)->contents, LFACE_VECTOR_SIZE); + vcopy (copy, 0, xvector_contents (lface), LFACE_VECTOR_SIZE); /* Changing a named face means that all realized faces depending on that face are invalid. Since we cannot tell which realized faces @@ -3128,6 +3251,8 @@ FRAME 0 means change the face on all frames, and change the default valid_p = XFIXNUM (value) != 0; else if (STRINGP (value)) valid_p = SCHARS (value) > 0; + else if (CONSP (value) && FIXNUMP (XCAR (value)) && FIXNUMP (XCDR (value))) + valid_p = true; else if (CONSP (value)) { Lisp_Object tem; @@ -3146,7 +3271,9 @@ FRAME 0 means change the face on all frames, and change the default if (EQ (k, QCline_width)) { - if (!FIXNUMP (v) || XFIXNUM (v) == 0) + if ((!CONSP(v) || !FIXNUMP (XCAR (v)) || XFIXNUM (XCAR (v)) == 0 + || !FIXNUMP (XCDR (v)) || XFIXNUM (XCDR (v)) == 0) + && (!FIXNUMP (v) || XFIXNUM (v) == 0)) break; } else if (EQ (k, QCcolor)) @@ -4352,15 +4479,15 @@ color_distance (Emacs_Color *x, Emacs_Color *y) See <https://www.compuphase.com/cmetric.htm> for more info. */ - long r = (x->red - y->red) >> 8; - long g = (x->green - y->green) >> 8; - long b = (x->blue - y->blue) >> 8; - long r_mean = (x->red + y->red) >> 9; + long long r = x->red - y->red; + long long g = x->green - y->green; + long long b = x->blue - y->blue; + long long r_mean = (x->red + y->red) >> 1; - return - (((512 + r_mean) * r * r) >> 8) - + 4 * g * g - + (((767 - r_mean) * b * b) >> 8); + return (((((2 * 65536 + r_mean) * r * r) >> 16) + + 4 * g * g + + (((2 * 65536 + 65535 - r_mean) * b * b) >> 16)) + >> 16); } @@ -4370,7 +4497,9 @@ COLOR1 and COLOR2 may be either strings containing the color name, or lists of the form (RED GREEN BLUE), each in the range 0 to 65535 inclusive. If FRAME is unspecified or nil, the current frame is used. If METRIC is specified, it should be a function that accepts -two lists of the form (RED GREEN BLUE) aforementioned. */) +two lists of the form (RED GREEN BLUE) aforementioned. +Despite the name, this is not a true distance metric as it does not satisfy +the triangle inequality. */) (Lisp_Object color1, Lisp_Object color2, Lisp_Object frame, Lisp_Object metric) { @@ -4927,7 +5056,7 @@ DEFUN ("face-attributes-as-vector", Fface_attributes_as_vector, /* If the distance (as returned by color_distance) between two colors is less than this, then they are considered the same, for determining - whether a color is supported or not. The range of values is 0-65535. */ + whether a color is supported or not. */ #define TTY_SAME_COLOR_THRESHOLD 10000 @@ -5594,7 +5723,7 @@ realize_default_face (struct frame *f) /* Realize the face; it must be fully-specified now. */ eassert (lface_fully_specified_p (XVECTOR (lface)->contents)); check_lface (lface); - memcpy (attrs, XVECTOR (lface)->contents, sizeof attrs); + memcpy (attrs, xvector_contents (lface), sizeof attrs); struct face *face = realize_face (c, attrs, DEFAULT_FACE_ID); #ifndef HAVE_WINDOW_SYSTEM @@ -5815,7 +5944,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->box_color = load_color (f, face, attrs[LFACE_BOX_INDEX], LFACE_BOX_INDEX); face->box = FACE_SIMPLE_BOX; - face->box_line_width = 1; + face->box_vertical_line_width = face->box_horizontal_line_width = 1; } else if (FIXNUMP (box)) { @@ -5823,9 +5952,19 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face. */ eassert (XFIXNUM (box) != 0); face->box = FACE_SIMPLE_BOX; - face->box_line_width = XFIXNUM (box); + face->box_vertical_line_width = eabs(XFIXNUM (box)); + face->box_horizontal_line_width = XFIXNUM (box); + face->box_color = face->foreground; + face->box_color_defaulted_p = true; + } + else if (CONSP (box) && FIXNUMP (XCAR (box)) && FIXNUMP (XCDR (box))) + { + /* `(VWIDTH . HWIDTH)'. */ + face->box = FACE_SIMPLE_BOX; face->box_color = face->foreground; face->box_color_defaulted_p = true; + face->box_vertical_line_width = XFIXNUM (XCAR (box)); + face->box_horizontal_line_width = XFIXNUM (XCDR (box)); } else if (CONSP (box)) { @@ -5834,7 +5973,7 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] face->box = FACE_SIMPLE_BOX; face->box_color = face->foreground; face->box_color_defaulted_p = true; - face->box_line_width = 1; + face->box_vertical_line_width = face->box_horizontal_line_width = 1; while (CONSP (box)) { @@ -5850,8 +5989,14 @@ realize_gui_face (struct face_cache *cache, Lisp_Object attrs[LFACE_VECTOR_SIZE] if (EQ (keyword, QCline_width)) { - if (FIXNUMP (value) && XFIXNUM (value) != 0) - face->box_line_width = XFIXNUM (value); + if (CONSP (value) && FIXNUMP (XCAR (value)) && FIXNUMP (XCDR (value))) { + face->box_vertical_line_width = XFIXNUM (XCAR (value)); + face->box_horizontal_line_width = XFIXNUM (XCDR (value)); + } + else if (FIXNUMP (value) && XFIXNUM (value) != 0) { + face->box_vertical_line_width = eabs (XFIXNUM (value)); + face->box_horizontal_line_width = XFIXNUM (value); + } } else if (EQ (keyword, QCcolor)) { @@ -6996,4 +7141,5 @@ clear the face cache, see `clear-face-cache'. */); defsubr (&Sinternal_face_x_get_resource); defsubr (&Sx_family_fonts); #endif + defsubr (&Scolor_values_from_color_spec); } diff --git a/src/xfns.c b/src/xfns.c index b89fac1cdac..2ab5080d977 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -1236,13 +1236,10 @@ x_set_mouse_color (struct frame *f, Lisp_Object arg, Lisp_Object oldval) for (i = 0; i < mouse_cursor_max; i++) { Lisp_Object shape_var = *mouse_cursor_types[i].shape_var_ptr; - if (!NILP (shape_var)) - { - CHECK_TYPE_RANGED_INTEGER (unsigned, shape_var); - cursor_data.cursor_num[i] = XFIXNUM (shape_var); - } - else - cursor_data.cursor_num[i] = mouse_cursor_types[i].default_shape; + cursor_data.cursor_num[i] + = (!NILP (shape_var) + ? check_uinteger_max (shape_var, UINT_MAX) + : mouse_cursor_types[i].default_shape); } block_input (); @@ -1807,10 +1804,7 @@ x_change_tool_bar_height (struct frame *f, int height) static void x_set_internal_border_width (struct frame *f, Lisp_Object arg, Lisp_Object oldval) { - int border; - - CHECK_TYPE_RANGED_INTEGER (int, arg); - border = max (XFIXNUM (arg), 0); + int border = check_int_nonnegative (arg); if (border != FRAME_INTERNAL_BORDER_WIDTH (f)) { @@ -3382,10 +3376,12 @@ x_icon (struct frame *f, Lisp_Object parms) = gui_frame_get_and_record_arg (f, parms, Qicon_left, 0, 0, RES_TYPE_NUMBER); Lisp_Object icon_y = gui_frame_get_and_record_arg (f, parms, Qicon_top, 0, 0, RES_TYPE_NUMBER); + int icon_xval, icon_yval; + if (!EQ (icon_x, Qunbound) && !EQ (icon_y, Qunbound)) { - CHECK_TYPE_RANGED_INTEGER (int, icon_x); - CHECK_TYPE_RANGED_INTEGER (int, icon_y); + icon_xval = check_integer_range (icon_x, INT_MIN, INT_MAX); + icon_yval = check_integer_range (icon_y, INT_MIN, INT_MAX); } else if (!EQ (icon_x, Qunbound) || !EQ (icon_y, Qunbound)) error ("Both left and top icon corners of icon must be specified"); @@ -3393,7 +3389,7 @@ x_icon (struct frame *f, Lisp_Object parms) block_input (); if (! EQ (icon_x, Qunbound)) - x_wm_set_icon_position (f, XFIXNUM (icon_x), XFIXNUM (icon_y)); + x_wm_set_icon_position (f, icon_xval, icon_yval); #if false /* gui_display_get_arg removes the visibility parameter as a side effect, but x_create_frame still needs it. */ @@ -3884,8 +3880,6 @@ This function is an internal primitive--use `make-frame' instead. */) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ @@ -5563,12 +5557,12 @@ The coordinates X and Y are interpreted in pixels relative to a position if (FRAME_INITIAL_P (f) || !FRAME_X_P (f)) return Qnil; - CHECK_TYPE_RANGED_INTEGER (int, x); - CHECK_TYPE_RANGED_INTEGER (int, y); + int xval = check_integer_range (x, INT_MIN, INT_MAX); + int yval = check_integer_range (y, INT_MIN, INT_MAX); block_input (); XWarpPointer (FRAME_X_DISPLAY (f), None, DefaultRootWindow (FRAME_X_DISPLAY (f)), - 0, 0, 0, 0, XFIXNUM (x), XFIXNUM (y)); + 0, 0, 0, 0, xval, yval); unblock_input (); return Qnil; @@ -6375,8 +6369,6 @@ x_create_tip_frame (struct x_display_info *dpyinfo, Lisp_Object parms) #ifdef HAVE_HARFBUZZ register_font_driver (&xfthbfont_driver, f); #endif -#else /* not HAVE_XFT */ - register_font_driver (&ftxfont_driver, f); #endif /* not HAVE_XFT */ #endif /* HAVE_FREETYPE */ #endif /* not USE_CAIRO */ diff --git a/src/xfont.c b/src/xfont.c index f6131dcec5a..1563b43bf97 100644 --- a/src/xfont.c +++ b/src/xfont.c @@ -166,7 +166,7 @@ xfont_encode_coding_xlfd (char *xlfd) while (*p0) { - int c = STRING_CHAR_ADVANCE (p0); + int c = string_char_advance (&p0); if (c >= 0x100) return -1; diff --git a/src/xmenu.c b/src/xmenu.c index 9201a283b47..dba7e88f486 100644 --- a/src/xmenu.c +++ b/src/xmenu.c @@ -763,7 +763,7 @@ set_frame_menubar (struct frame *f, bool first_time, bool deep_p) /* Save the frame's previous menu bar contents data. */ if (previous_menu_items_used) - memcpy (previous_items, XVECTOR (f->menu_bar_vector)->contents, + memcpy (previous_items, xvector_contents (f->menu_bar_vector), previous_menu_items_used * word_size); /* Fill in menu_items with the current menu bar contents. diff --git a/src/xrdb.c b/src/xrdb.c index ad7155c106e..e3a1fcb15a9 100644 --- a/src/xrdb.c +++ b/src/xrdb.c @@ -353,7 +353,7 @@ get_environ_db (void) p = filename = xmalloc (strlen (home) + 1 + sizeof xdefaults + 1 + SBYTES (system_name)); char *e = splice_dir_file (p, home, xdefaults); - *e++ = '/'; + *e++ = '-'; lispstpcpy (e, system_name); } } diff --git a/src/xterm.c b/src/xterm.c index 44396955ed0..6340700cb89 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -1750,7 +1750,7 @@ x_draw_glyph_string_background (struct glyph_string *s, bool force_p) shouldn't be drawn in the first place. */ if (!s->background_filled_p) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (s->stippled_p) { @@ -1795,7 +1795,7 @@ x_draw_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -1845,7 +1845,7 @@ x_draw_glyph_string_foreground (struct glyph_string *s) if (!(s->for_overlaps || (s->background_filled_p && s->hl != DRAW_CURSOR))) { - int box_line_width = max (s->face->box_line_width, 0); + int box_line_width = max (s->face->box_horizontal_line_width, 0); if (s->stippled_p) { @@ -1889,7 +1889,7 @@ x_draw_composite_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -2000,7 +2000,7 @@ x_draw_glyphless_glyph_string_foreground (struct glyph_string *s) of S to the right of that box line. */ if (s->face && s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p) - x = s->x + eabs (s->face->box_line_width); + x = s->x + max (s->face->box_vertical_line_width, 0); else x = s->x; @@ -2376,8 +2376,6 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) x_query_colors (f, bgcolor, 1); } -#define HEX_COLOR_NAME_LENGTH 32 - /* On frame F, translate the color name to RGB values. Use cached information, if possible. @@ -2389,44 +2387,23 @@ x_query_frame_background_color (struct frame *f, XColor *bgcolor) Status x_parse_color (struct frame *f, const char *color_name, XColor *color) { + /* Don't pass #RGB strings directly to XParseColor, because that + follows the X convention of zero-extending each channel + value: #f00 means #f00000. We want the convention of scaling + channel values, so #f00 means #ff0000, just as it does for + HTML, SVG, and CSS. */ + unsigned short r, g, b; + if (parse_color_spec (color_name, &r, &g, &b)) + { + color->red = r; + color->green = g; + color->blue = b; + return 1; + } + Display *dpy = FRAME_X_DISPLAY (f); Colormap cmap = FRAME_X_COLORMAP (f); struct color_name_cache_entry *cache_entry; - - if (color_name[0] == '#') - { - /* Don't pass #RGB strings directly to XParseColor, because that - follows the X convention of zero-extending each channel - value: #f00 means #f00000. We want the convention of scaling - channel values, so #f00 means #ff0000, just as it does for - HTML, SVG, and CSS. - - So we translate #f00 to rgb:f/0/0, which X handles - differently. */ - char rgb_color_name[HEX_COLOR_NAME_LENGTH]; - int len = strlen (color_name); - int digits_per_channel; - if (len == 4) - digits_per_channel = 1; - else if (len == 7) - digits_per_channel = 2; - else if (len == 10) - digits_per_channel = 3; - else if (len == 13) - digits_per_channel = 4; - else - return 0; - - snprintf (rgb_color_name, sizeof rgb_color_name, "rgb:%.*s/%.*s/%.*s", - digits_per_channel, color_name + 1, - digits_per_channel, color_name + digits_per_channel + 1, - digits_per_channel, color_name + 2 * digits_per_channel + 1); - - /* The rgb form is parsed directly by XParseColor without - talking to the X server. No need for caching. */ - return XParseColor (dpy, cmap, rgb_color_name, color); - } - for (cache_entry = FRAME_DISPLAY_INFO (f)->color_names; cache_entry; cache_entry = cache_entry->next) { @@ -2765,7 +2742,7 @@ x_setup_relief_colors (struct glyph_string *s) static void x_draw_relief_rect (struct frame *f, int left_x, int top_y, int right_x, int bottom_y, - int width, bool raised_p, bool top_p, bool bot_p, + int hwidth, int vwidth, bool raised_p, bool top_p, bool bot_p, bool left_p, bool right_p, XRectangle *clip_rect) { @@ -2790,7 +2767,7 @@ x_draw_relief_rect (struct frame *f, if (left_p) { x_fill_rectangle (f, top_left_gc, left_x, top_y, - width, bottom_y + 1 - top_y); + vwidth, bottom_y + 1 - top_y); if (top_p) corners |= 1 << CORNER_TOP_LEFT; if (bot_p) @@ -2798,8 +2775,8 @@ x_draw_relief_rect (struct frame *f, } if (right_p) { - x_fill_rectangle (f, bottom_right_gc, right_x + 1 - width, top_y, - width, bottom_y + 1 - top_y); + x_fill_rectangle (f, bottom_right_gc, right_x + 1 - vwidth, top_y, + vwidth, bottom_y + 1 - top_y); if (top_p) corners |= 1 << CORNER_TOP_RIGHT; if (bot_p) @@ -2809,25 +2786,25 @@ x_draw_relief_rect (struct frame *f, { if (!right_p) x_fill_rectangle (f, top_left_gc, left_x, top_y, - right_x + 1 - left_x, width); + right_x + 1 - left_x, hwidth); else x_fill_trapezoid_for_relief (f, top_left_gc, left_x, top_y, - right_x + 1 - left_x, width, 1); + right_x + 1 - left_x, hwidth, 1); } if (bot_p) { if (!left_p) - x_fill_rectangle (f, bottom_right_gc, left_x, bottom_y + 1 - width, - right_x + 1 - left_x, width); + x_fill_rectangle (f, bottom_right_gc, left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth); else x_fill_trapezoid_for_relief (f, bottom_right_gc, - left_x, bottom_y + 1 - width, - right_x + 1 - left_x, width, 0); + left_x, bottom_y + 1 - hwidth, + right_x + 1 - left_x, hwidth, 0); } - if (left_p && width != 1) + if (left_p && vwidth > 1) x_fill_rectangle (f, bottom_right_gc, left_x, top_y, 1, bottom_y + 1 - top_y); - if (top_p && width != 1) + if (top_p && hwidth > 1) x_fill_rectangle (f, bottom_right_gc, left_x, top_y, right_x + 1 - left_x, 1); if (corners) @@ -2861,12 +2838,12 @@ x_draw_relief_rect (struct frame *f, /* Top. */ if (top_p) { - if (width == 1) + if (hwidth == 1) XDrawLine (dpy, drawable, gc, left_x + left_p, top_y, right_x + !right_p, top_y); - for (i = 1; i < width; ++i) + for (i = 1; i < hwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i * left_p, top_y + i, right_x + 1 - i * right_p, top_y + i); @@ -2875,13 +2852,10 @@ x_draw_relief_rect (struct frame *f, /* Left. */ if (left_p) { - if (width == 1) + if (vwidth == 1) XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); - x_clear_area(f, left_x, top_y, 1, 1); - x_clear_area(f, left_x, bottom_y, 1, 1); - - for (i = (width > 1 ? 1 : 0); i < width; ++i) + for (i = 1; i < vwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i, top_y + (i + 1) * top_p, left_x + i, bottom_y + 1 - (i + 1) * bot_p); @@ -2894,26 +2868,25 @@ x_draw_relief_rect (struct frame *f, gc = f->output_data.x->white_relief.gc; XSetClipRectangles (dpy, gc, 0, 0, clip_rect, 1, Unsorted); - if (width > 1) - { - /* Outermost top line. */ - if (top_p) - XDrawLine (dpy, drawable, gc, - left_x + left_p, top_y, - right_x + !right_p, top_y); + /* Outermost top line. */ + if (top_p && hwidth > 1) + XDrawLine (dpy, drawable, gc, + left_x + left_p, top_y, + right_x + !right_p, top_y); - /* Outermost left line. */ - if (left_p) - XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); - } + /* Outermost left line. */ + if (left_p && vwidth > 1) + XDrawLine (dpy, drawable, gc, left_x, top_y + 1, left_x, bottom_y); /* Bottom. */ if (bot_p) { - XDrawLine (dpy, drawable, gc, - left_x + left_p, bottom_y, - right_x + !right_p, bottom_y); - for (i = 1; i < width; ++i) + if (hwidth >= 1) + XDrawLine (dpy, drawable, gc, + left_x + left_p, bottom_y, + right_x + !right_p, bottom_y); + + for (i = 1; i < hwidth; ++i) XDrawLine (dpy, drawable, gc, left_x + i * left_p, bottom_y - i, right_x + 1 - i * right_p, bottom_y - i); @@ -2922,9 +2895,7 @@ x_draw_relief_rect (struct frame *f, /* Right. */ if (right_p) { - x_clear_area(f, right_x, top_y, 1, 1); - x_clear_area(f, right_x, bottom_y, 1, 1); - for (i = 0; i < width; ++i) + for (i = 0; i < vwidth; ++i) XDrawLine (dpy, drawable, gc, right_x - i, top_y + (i + 1) * top_p, right_x - i, bottom_y + 1 - (i + 1) * bot_p); @@ -2945,8 +2916,8 @@ x_draw_relief_rect (struct frame *f, static void x_draw_box_rect (struct glyph_string *s, - int left_x, int top_y, int right_x, int bottom_y, int width, - bool left_p, bool right_p, XRectangle *clip_rect) + int left_x, int top_y, int right_x, int bottom_y, int hwidth, + int vwidth, bool left_p, bool right_p, XRectangle *clip_rect) { Display *display = FRAME_X_DISPLAY (s->f); XGCValues xgcv; @@ -2957,21 +2928,21 @@ x_draw_box_rect (struct glyph_string *s, /* Top. */ x_fill_rectangle (s->f, s->gc, - left_x, top_y, right_x - left_x + 1, width); + left_x, top_y, right_x - left_x + 1, hwidth); /* Left. */ if (left_p) x_fill_rectangle (s->f, s->gc, - left_x, top_y, width, bottom_y - top_y + 1); + left_x, top_y, vwidth, bottom_y - top_y + 1); /* Bottom. */ x_fill_rectangle (s->f, s->gc, - left_x, bottom_y - width + 1, right_x - left_x + 1, width); + left_x, bottom_y - hwidth + 1, right_x - left_x + 1, hwidth); /* Right. */ if (right_p) x_fill_rectangle (s->f, s->gc, - right_x - width + 1, top_y, width, bottom_y - top_y + 1); + right_x - vwidth + 1, top_y, vwidth, bottom_y - top_y + 1); XSetForeground (display, s->gc, xgcv.foreground); x_reset_clip_rectangles (s->f, s->gc); @@ -2983,7 +2954,7 @@ x_draw_box_rect (struct glyph_string *s, static void x_draw_glyph_string_box (struct glyph_string *s) { - int width, left_x, right_x, top_y, bottom_y, last_x; + int hwidth, vwidth, left_x, right_x, top_y, bottom_y, last_x; bool raised_p, left_p, right_p; struct glyph *last_glyph; XRectangle clip_rect; @@ -2992,12 +2963,29 @@ x_draw_glyph_string_box (struct glyph_string *s) ? WINDOW_RIGHT_EDGE_X (s->w) : window_box_right (s->w, s->area)); - /* The glyph that may have a right box line. */ - last_glyph = (s->cmp || s->img - ? s->first_glyph - : s->first_glyph + s->nchars - 1); + /* The glyph that may have a right box line. For static + compositions and images, the right-box flag is on the first glyph + of the glyph string; for other types it's on the last glyph. */ + if (s->cmp || s->img) + last_glyph = s->first_glyph; + else if (s->first_glyph->type == COMPOSITE_GLYPH + && s->first_glyph->u.cmp.automatic) + { + /* For automatic compositions, we need to look up the last glyph + in the composition. */ + struct glyph *end = s->row->glyphs[s->area] + s->row->used[s->area]; + struct glyph *g = s->first_glyph; + for (last_glyph = g++; + g < end && g->u.cmp.automatic && g->u.cmp.id == s->cmp_id + && g->slice.cmp.to < s->cmp_to; + last_glyph = g++) + ; + } + else + last_glyph = s->first_glyph + s->nchars - 1; - width = eabs (s->face->box_line_width); + vwidth = eabs (s->face->box_vertical_line_width); + hwidth = eabs (s->face->box_horizontal_line_width); raised_p = s->face->box == FACE_RAISED_BOX; left_x = s->x; right_x = (s->row->full_width_p && s->extends_to_end_of_line_p @@ -3018,13 +3006,13 @@ x_draw_glyph_string_box (struct glyph_string *s) get_glyph_string_clip_rect (s, &clip_rect); if (s->face->box == FACE_SIMPLE_BOX) - x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, width, - left_p, right_p, &clip_rect); + x_draw_box_rect (s, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, left_p, right_p, &clip_rect); else { x_setup_relief_colors (s); - x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, - width, raised_p, true, true, left_p, right_p, + x_draw_relief_rect (s->f, left_x, top_y, right_x, bottom_y, hwidth, + vwidth, raised_p, true, true, left_p, right_p, &clip_rect); } } @@ -3082,7 +3070,7 @@ x_draw_image_foreground (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3201,7 +3189,7 @@ x_draw_image_relief (struct glyph_string *s) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3269,7 +3257,7 @@ x_draw_image_relief (struct glyph_string *s) x_setup_relief_colors (s); get_glyph_string_clip_rect (s, &r); - x_draw_relief_rect (s->f, x, y, x1, y1, thick, raised_p, + x_draw_relief_rect (s->f, x, y, x1, y1, thick, thick, raised_p, top_p, bot_p, left_p, right_p, &r); } @@ -3288,7 +3276,7 @@ x_draw_image_foreground_1 (struct glyph_string *s, Pixmap pixmap) if (s->face->box != FACE_NO_BOX && s->first_glyph->left_box_line_p && s->slice.x == 0) - x += eabs (s->face->box_line_width); + x += max (s->face->box_vertical_line_width, 0); /* If there is a margin around the image, adjust x- and y-position by that margin. */ @@ -3390,8 +3378,8 @@ x_draw_glyph_string_bg_rect (struct glyph_string *s, int x, int y, int w, int h) static void x_draw_image_glyph_string (struct glyph_string *s) { - int box_line_hwidth = eabs (s->face->box_line_width); - int box_line_vwidth = max (s->face->box_line_width, 0); + int box_line_hwidth = max (s->face->box_vertical_line_width, 0); + int box_line_vwidth = max (s->face->box_horizontal_line_width, 0); int height; #ifndef USE_CAIRO Display *display = FRAME_X_DISPLAY (s->f); @@ -4786,6 +4774,16 @@ x_detect_focus_change (struct x_display_info *dpyinfo, struct frame *frame, case FocusIn: case FocusOut: + /* Ignore transient focus events from hotkeys, window manager + gadgets, and other odd sources. Some buggy window managers + (e.g., Muffin 4.2.4) send FocusIn events of this type without + corresponding FocusOut events even when some other window + really has focus, and these kinds of focus event don't + correspond to real user input changes. GTK+ uses the same + filtering. */ + if (event->xfocus.mode == NotifyGrab || + event->xfocus.mode == NotifyUngrab) + return; x_focus_changed (event->type, (event->xfocus.detail == NotifyPointer ? FOCUS_IMPLICIT : FOCUS_EXPLICIT), @@ -8701,7 +8699,7 @@ handle_one_xevent (struct x_display_info *dpyinfo, if (nchars == nbytes) ch = copy_bufptr[i], len = 1; else - ch = STRING_CHAR_AND_LENGTH (copy_bufptr + i, len); + ch = string_char_and_length (copy_bufptr + i, &len); inev.ie.kind = (SINGLE_BYTE_CHAR_P (ch) ? ASCII_KEYSTROKE_EVENT : MULTIBYTE_CHAR_KEYSTROKE_EVENT); diff --git a/src/xwidget.c b/src/xwidget.c index ea8987f5b3b..0347f1e6483 100644 --- a/src/xwidget.c +++ b/src/xwidget.c @@ -750,11 +750,9 @@ DEFUN ("xwidget-resize", Fxwidget_resize, Sxwidget_resize, 3, 3, 0, (Lisp_Object xwidget, Lisp_Object new_width, Lisp_Object new_height) { CHECK_XWIDGET (xwidget); - CHECK_RANGED_INTEGER (new_width, 0, INT_MAX); - CHECK_RANGED_INTEGER (new_height, 0, INT_MAX); + int w = check_integer_range (new_width, 0, INT_MAX); + int h = check_integer_range (new_height, 0, INT_MAX); struct xwidget *xw = XXWIDGET (xwidget); - int w = XFIXNAT (new_width); - int h = XFIXNAT (new_height); xw->width = w; xw->height = h; diff --git a/test/Makefile.in b/test/Makefile.in index f03c194a7cb..c4840670e61 100644 --- a/test/Makefile.in +++ b/test/Makefile.in @@ -255,12 +255,10 @@ else FPIC_CFLAGS = -fPIC endif -GMP_LIB = @GMP_LIB@ -GMP_OBJ = $(if @GMP_OBJ@, ../src/@GMP_OBJ@) +GMP_H = @GMP_H@ +LIB_GMP = @LIB_GMP@ -# Note: emacs-module.h is generated from emacs-module.h.in, hence we -# look in ../src, not $(srcdir)/../src. -MODULE_CFLAGS = -I../src -I$(srcdir)/../lib \ +MODULE_CFLAGS = -I../src -I$(srcdir)/../src -I../lib -I$(srcdir)/../lib \ $(FPIC_CFLAGS) $(PROFILING_CFLAGS) \ $(WARN_CFLAGS) $(WERROR_CFLAGS) $(CFLAGS) @@ -273,7 +271,8 @@ src/emacs-module-tests.log src/emacs-module-tests.elc: $(test_module) $(test_module): $(test_module:${SO}=.c) ../src/emacs-module.h $(AM_V_at)${MKDIR_P} $(dir $@) $(AM_V_CCLD)$(CC) -shared $(CPPFLAGS) $(MODULE_CFLAGS) $(LDFLAGS) \ - -o $@ $< $(GMP_LIB) $(GMP_OBJ:.o=.c) \ + -o $@ $< $(LIB_GMP) \ + $(and $(GMP_H),$(srcdir)/../lib/mini-gmp-gnulib.c) \ $(srcdir)/../lib/timespec.c $(srcdir)/../lib/gettime.c endif diff --git a/test/data/emacs-module/mod-test.c b/test/data/emacs-module/mod-test.c index 8d1b421bb40..f72b85a5d8e 100644 --- a/test/data/emacs-module/mod-test.c +++ b/test/data/emacs-module/mod-test.c @@ -24,17 +24,26 @@ along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. */ #include <errno.h> #include <limits.h> +#include <stdint.h> #include <stdio.h> #include <stdlib.h> #include <string.h> #include <time.h> -#ifdef HAVE_GMP -#include <gmp.h> -#else -#include "mini-gmp.h" +#ifdef WINDOWSNT +/* Cannot include <process.h> because of the local header by the same + name, sigh. */ +uintptr_t _beginthread (void (__cdecl *)(void *), unsigned, void *); +# if !defined __x86_64__ +# define ALIGN_STACK __attribute__((force_align_arg_pointer)) +# endif +# include <windows.h> /* for Sleep */ +#else /* !WINDOWSNT */ +# include <pthread.h> +# include <unistd.h> #endif +#include <gmp.h> #include <emacs-module.h> #include "timespec.h" @@ -86,6 +95,7 @@ static emacs_value Fmod_test_sum (emacs_env *env, ptrdiff_t nargs, emacs_value args[], void *data) { assert (nargs == 2); + assert ((uintptr_t) data == 0x1234); intmax_t a = env->extract_integer (env, args[0]); intmax_t b = env->extract_integer (env, args[1]); @@ -354,7 +364,7 @@ Fmod_test_invalid_store_copy (emacs_env *env, ptrdiff_t nargs, } /* An invalid finalizer: Finalizers are run during garbage collection, - where Lisp code can’t be executed. -module-assertions tests for + where Lisp code can't be executed. -module-assertions tests for this case. */ static emacs_env *current_env; @@ -375,9 +385,9 @@ Fmod_test_invalid_finalizer (emacs_env *env, ptrdiff_t nargs, emacs_value *args, } static void -signal_errno (emacs_env *env, const char *function) +signal_system_error (emacs_env *env, int error, const char *function) { - const char *message = strerror (errno); + const char *message = strerror (error); emacs_value message_value = env->make_string (env, message, strlen (message)); emacs_value symbol = env->intern (env, "file-error"); emacs_value elements[2] @@ -386,6 +396,12 @@ signal_errno (emacs_env *env, const char *function) env->non_local_exit_signal (env, symbol, data); } +static void +signal_errno (emacs_env *env, const char *function) +{ + signal_system_error (env, errno, function); +} + /* A long-running operation that occasionally calls `should_quit' or `process_input'. */ @@ -430,15 +446,20 @@ Fmod_test_add_nanosecond (emacs_env *env, ptrdiff_t nargs, emacs_value *args, } static void -memory_full (emacs_env *env) +signal_error (emacs_env *env, const char *message) { - const char *message = "Memory exhausted"; emacs_value data = env->make_string (env, message, strlen (message)); env->non_local_exit_signal (env, env->intern (env, "error"), env->funcall (env, env->intern (env, "list"), 1, &data)); } +static void +memory_full (emacs_env *env) +{ + signal_error (env, "Memory exhausted"); +} + enum { max_count = ((SIZE_MAX < PTRDIFF_MAX ? SIZE_MAX : PTRDIFF_MAX) @@ -547,6 +568,109 @@ Fmod_test_double (emacs_env *env, ptrdiff_t nargs, emacs_value *args, return result; } +static int function_data; +static int finalizer_calls_with_correct_data; +static int finalizer_calls_with_incorrect_data; + +static void +finalizer (void *data) +{ + if (data == &function_data) + ++finalizer_calls_with_correct_data; + else + ++finalizer_calls_with_incorrect_data; +} + +static emacs_value +Fmod_test_make_function_with_finalizer (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value fun + = env->make_function (env, 2, 2, Fmod_test_sum, NULL, &function_data); + env->set_function_finalizer (env, fun, finalizer); + if (env->get_function_finalizer (env, fun) != finalizer) + signal_error (env, "Invalid finalizer"); + return fun; +} + +static emacs_value +Fmod_test_function_finalizer_calls (emacs_env *env, ptrdiff_t nargs, + emacs_value *args, void *data) +{ + emacs_value Flist = env->intern (env, "list"); + emacs_value list_args[] + = {env->make_integer (env, finalizer_calls_with_correct_data), + env->make_integer (env, finalizer_calls_with_incorrect_data)}; + return env->funcall (env, Flist, 2, list_args); +} + +static void +sleep_for_half_second (void) +{ + /* mingw.org's MinGW has nanosleep, but MinGW64 doesn't. */ +#ifdef WINDOWSNT + Sleep (500); +#else + const struct timespec sleep = {0, 500000000}; + if (nanosleep (&sleep, NULL) != 0) + perror ("nanosleep"); +#endif +} + +#ifdef WINDOWSNT +static void ALIGN_STACK +#else +static void * +#endif +write_to_pipe (void *arg) +{ + /* We sleep a bit to test that writing to a pipe is indeed possible + if no environment is active. */ + sleep_for_half_second (); + FILE *stream = arg; + /* The string below should be identical to the one we compare with + in emacs-module-tests.el:module/async-pipe. */ + if (fputs ("data from thread", stream) < 0) + perror ("fputs"); + if (fclose (stream) != 0) + perror ("close"); +#ifndef WINDOWSNT + return NULL; +#endif +} + +static emacs_value +Fmod_test_async_pipe (emacs_env *env, ptrdiff_t nargs, emacs_value *args, + void *data) +{ + assert (nargs == 1); + int fd = env->open_channel (env, args[0]); + if (env->non_local_exit_check (env) != emacs_funcall_exit_return) + return NULL; + FILE *stream = fdopen (fd, "w"); + if (stream == NULL) + { + signal_errno (env, "fdopen"); + return NULL; + } +#ifdef WINDOWSNT + uintptr_t thd = _beginthread (write_to_pipe, 0, stream); + int error = (thd == (uintptr_t)-1L) ? errno : 0; +#else /* !WINDOWSNT */ + pthread_t thread; + int error + = pthread_create (&thread, NULL, write_to_pipe, stream); +#endif + if (error != 0) + { + signal_system_error (env, error, "thread create"); + if (fclose (stream) != 0) + perror ("fclose"); + return NULL; + } + return env->intern (env, "nil"); +} + /* Lisp utilities for easier readability (simple wrappers). */ /* Provide FEATURE to Emacs. */ @@ -603,7 +727,8 @@ emacs_module_init (struct emacs_runtime *ert) env->make_function (env, amin, amax, csym, doc, data)) DEFUN ("mod-test-return-t", Fmod_test_return_t, 1, 1, NULL, NULL); - DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn a b)", NULL); + DEFUN ("mod-test-sum", Fmod_test_sum, 2, 2, "Return A + B\n\n(fn a b)", + (void *) (uintptr_t) 0x1234); DEFUN ("mod-test-signal", Fmod_test_signal, 0, 0, NULL, NULL); DEFUN ("mod-test-throw", Fmod_test_throw, 0, 0, NULL, NULL); DEFUN ("mod-test-non-local-exit-funcall", Fmod_test_non_local_exit_funcall, @@ -629,6 +754,11 @@ emacs_module_init (struct emacs_runtime *ert) DEFUN ("mod-test-add-nanosecond", Fmod_test_add_nanosecond, 1, 1, NULL, NULL); DEFUN ("mod-test-nanoseconds", Fmod_test_nanoseconds, 1, 1, NULL, NULL); DEFUN ("mod-test-double", Fmod_test_double, 1, 1, NULL, NULL); + DEFUN ("mod-test-make-function-with-finalizer", + Fmod_test_make_function_with_finalizer, 0, 0, NULL, NULL); + DEFUN ("mod-test-function-finalizer-calls", + Fmod_test_function_finalizer_calls, 0, 0, NULL, NULL); + DEFUN ("mod-test-async-pipe", Fmod_test_async_pipe, 1, 1, NULL, NULL); #undef DEFUN diff --git a/test/lisp/apropos-tests.el b/test/lisp/apropos-tests.el new file mode 100644 index 00000000000..4c5522d14c2 --- /dev/null +++ b/test/lisp/apropos-tests.el @@ -0,0 +1,133 @@ +;;; apropos-tests.el --- Tests for apropos.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'apropos) +(require 'ert) + +(ert-deftest apropos-tests-words-to-regexp-1 () + (let ((re (apropos-words-to-regexp '("foo" "bar") "baz"))) + (should (string-match-p re "foobazbar")) + (should (string-match-p re "barbazfoo")) + (should-not (string-match-p re "foo-bar")) + (should-not (string-match-p re "foobazbazbar")))) + +(ert-deftest apropos-tests-words-to-regexp-2 () + (let ((re (apropos-words-to-regexp '("foo" "bar" "baz") "-"))) + (should-not (string-match-p re "foo")) + (should-not (string-match-p re "foobar")) + (should (string-match-p re "foo-bar")) + (should (string-match-p re "foo-baz")))) + +(ert-deftest apropos-tests-parse-pattern-1 () + (apropos-parse-pattern '("foo")) + (should (string-match-p apropos-regexp "foo")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "bar-foo")) + (should (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar"))) + +(ert-deftest apropos-tests-parse-pattern-2 () + (apropos-parse-pattern '("foo" "bar")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "bar-foo")) + (should-not (string-match-p apropos-regexp "foo")) + (should-not (string-match-p apropos-regexp "bar")) + (should-not (string-match-p apropos-regexp "baz")) + (should-not (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar-bar"))) + +(ert-deftest apropos-tests-parse-pattern-3 () + (apropos-parse-pattern '("foo" "bar" "baz")) + (should (string-match-p apropos-regexp "foo-bar")) + (should (string-match-p apropos-regexp "foo-baz")) + (should (string-match-p apropos-regexp "bar-foo")) + (should (string-match-p apropos-regexp "bar-baz")) + (should (string-match-p apropos-regexp "baz-foo")) + (should (string-match-p apropos-regexp "baz-bar")) + (should-not (string-match-p apropos-regexp "foo")) + (should-not (string-match-p apropos-regexp "bar")) + (should-not (string-match-p apropos-regexp "baz")) + (should-not (string-match-p apropos-regexp "foo-foo")) + (should-not (string-match-p apropos-regexp "bar-bar")) + (should-not (string-match-p apropos-regexp "baz-baz"))) + +(ert-deftest apropos-tests-parse-pattern-single-regexp () + (apropos-parse-pattern "foo+bar") + (should-not (string-match-p apropos-regexp "fobar")) + (should (string-match-p apropos-regexp "foobar")) + (should (string-match-p apropos-regexp "fooobar"))) + +(ert-deftest apropos-tests-parse-pattern-synonyms () + (let ((apropos-synonyms '(("find" "open" "edit")))) + (apropos-parse-pattern '("open")) + (should (string-match-p apropos-regexp "find-file")) + (should (string-match-p apropos-regexp "open-file")) + (should (string-match-p apropos-regexp "edit-file")))) + +(ert-deftest apropos-tests-calc-scores () + (let ((str "Return apropos score for string STR.")) + (should (equal (apropos-calc-scores str '("apr")) '(7))) + (should (equal (apropos-calc-scores str '("apr" "str")) '(25 7))) + (should (equal (apropos-calc-scores str '("appr" "str")) '(25))) + (should-not (apropos-calc-scores str '("appr" "strr"))))) + +(ert-deftest apropos-tests-score-str () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-str "baz") + (apropos-score-str "foo baz") + (apropos-score-str "foo bar baz")))) + +(ert-deftest apropos-tests-score-doc () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-doc "baz") + (apropos-score-doc "foo baz") + (apropos-score-doc "foo bar baz")))) + +(ert-deftest apropos-tests-score-symbol () + (apropos-parse-pattern '("foo" "bar")) + (should (< (apropos-score-symbol 'baz) + (apropos-score-symbol 'foo-baz) + (apropos-score-symbol 'foo-bar-baz)))) + +(ert-deftest apropos-tests-true-hit () + (should-not (apropos-true-hit "foo" '("foo" "bar"))) + (should (apropos-true-hit "foo bar" '("foo" "bar"))) + (should (apropos-true-hit "foo bar baz" '("foo" "bar")))) + +(ert-deftest apropos-tests-format-plist () + (setplist 'foo '(a 1 b (2 3) c nil)) + (apropos-parse-pattern '("b")) + (should (equal (apropos-format-plist 'foo ", ") + "a 1, b (2 3), c nil")) + (should (equal (apropos-format-plist 'foo ", " t) + "b (2 3)")) + (apropos-parse-pattern '("d")) + (should-not (apropos-format-plist 'foo ", " t))) + +(provide 'apropos-tests) +;;; apropos-tests.el ends here diff --git a/test/lisp/arc-mode-tests.el b/test/lisp/arc-mode-tests.el index df658b98139..22ca7e2ec55 100644 --- a/test/lisp/arc-mode-tests.el +++ b/test/lisp/arc-mode-tests.el @@ -28,7 +28,7 @@ (let ((alist (list (cons 448 "-rwx------") (cons 420 "-rw-r--r--") (cons 292 "-r--r--r--") - (cons 512 "----------") + (cons 512 "---------T") (cons 1024 "------S---") ; Bug#28092 (cons 2048 "---S------")))) (dolist (x alist) diff --git a/test/lisp/auth-source-pass-tests.el b/test/lisp/auth-source-pass-tests.el index 10ed9c39fbb..677abb33cc9 100644 --- a/test/lisp/auth-source-pass-tests.el +++ b/test/lisp/auth-source-pass-tests.el @@ -353,6 +353,10 @@ HOSTNAME, USER and PORT are passed unchanged to (auth-source-pass--with-store '(("bar.com:8080")) (should (auth-source-pass-match-entry-p "bar.com:8080" "bar.com" nil "8080")))) +(ert-deftest auth-source-pass--matching-entries-find-entries-with-a-port-when-passed-multiple-ports () + (auth-source-pass--with-store '(("bar.com:8080")) + (should (auth-source-pass-match-entry-p "bar.com:8080" "bar.com" nil '("http" "https" "80" "8080"))))) + (ert-deftest auth-source-pass--matching-entries-find-entries-with-slash () ;; match if entry filename matches user (auth-source-pass--with-store '(("foo.com/user")) diff --git a/test/lisp/autoinsert-tests.el b/test/lisp/autoinsert-tests.el index 574763c4b3d..eafa9c6c02c 100644 --- a/test/lisp/autoinsert-tests.el +++ b/test/lisp/autoinsert-tests.el @@ -79,10 +79,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-before () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar"))) + (lambda () (insert "bar"))) (with-temp-buffer (text-mode) (auto-insert) @@ -90,10 +90,10 @@ (ert-deftest autoinsert-tests-define-auto-insert-after () (let ((auto-insert-alist - (list (cons 'text-mode '(lambda () (insert "foo"))))) + (list (cons 'text-mode (lambda () (insert "foo"))))) (auto-insert-query nil)) (define-auto-insert 'text-mode - '(lambda () (insert "bar")) + (lambda () (insert "bar")) t) (with-temp-buffer (text-mode) diff --git a/test/lisp/autorevert-tests.el b/test/lisp/autorevert-tests.el index f7c5580b111..ec3e4bb77ba 100644 --- a/test/lisp/autorevert-tests.el +++ b/test/lisp/autorevert-tests.el @@ -59,8 +59,7 @@ auto-revert-notify-exclude-dir-regexp "nothing-to-be-excluded" auto-revert-stop-on-user-input nil file-notify-debug nil - tramp-verbose 0 - tramp-message-show-message nil) + tramp-verbose 0) (defconst auto-revert--timeout (1+ auto-revert-interval) "Time to wait for a message.") diff --git a/test/lisp/battery-tests.el b/test/lisp/battery-tests.el index 052ae49a800..8d7cc7fccf3 100644 --- a/test/lisp/battery-tests.el +++ b/test/lisp/battery-tests.el @@ -22,9 +22,9 @@ (require 'battery) (ert-deftest battery-linux-proc-apm-regexp () - "Test `battery-linux-proc-apm-regexp'." + "Test `rx' definition `battery--linux-proc-apm'." (let ((str "1.16 1.2 0x07 0x01 0xff 0x80 -1% -1 ?")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -36,7 +36,7 @@ (should (equal (match-string 8 str) "-1")) (should (equal (match-string 9 str) "?"))) (let ((str "1.16 1.2 0x03 0x00 0x00 0x01 99% 1792 min")) - (should (string-match battery-linux-proc-apm-regexp str)) + (should (string-match (rx battery--linux-proc-apm) str)) (should (equal (match-string 0 str) str)) (should (equal (match-string 1 str) "1.16")) (should (equal (match-string 2 str) "1.2")) @@ -48,11 +48,107 @@ (should (equal (match-string 8 str) "1792")) (should (equal (match-string 9 str) "min")))) +(ert-deftest battery-acpi-rate-regexp () + "Test `rx' definition `battery--acpi-rate'." + (let ((str "01 mA")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mA"))) + (let ((str "23 mW")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (let ((str "23 mWh")) + (should (string-match (rx (battery--acpi-rate)) str)) + (should (equal (match-string 0 str) "23 mW")) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mW"))) + (should-not (string-match (rx (battery--acpi-rate) eos) "45 mWh"))) + +(ert-deftest battery-acpi-capacity-regexp () + "Test `rx' definition `battery--acpi-capacity'." + (let ((str "01 mAh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "01")) + (should (equal (match-string 2 str) "mAh"))) + (let ((str "23 mWh")) + (should (string-match (rx battery--acpi-capacity) str)) + (should (equal (match-string 0 str) str)) + (should (equal (match-string 1 str) "23")) + (should (equal (match-string 2 str) "mWh"))) + (should-not (string-match (rx battery--acpi-capacity eos) "45 mW"))) + +(ert-deftest battery-upower-state () + "Test `battery--upower-state'." + ;; Charging. + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 1)) total) 'charging))) + (dolist (state '(nil 0 1 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'charging) + 'charging))) + ;; Discharging. + (dolist (total '(nil discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 2)) total) 'discharging))) + (dolist (state '(nil 0 2 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'discharging) + 'discharging))) + ;; Pending charge. + (dolist (total '(nil empty fully-charged pending-charge pending-discharge)) + (should (eq (battery--upower-state '(("State" . 5)) total) + 'pending-charge))) + (dolist (state '(nil 0 3 4 5 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-charge) + 'pending-charge))) + ;; Pending discharge. + (dolist (total '(nil empty fully-charged pending-discharge)) + (should (eq (battery--upower-state '(("State" . 6)) total) + 'pending-discharge))) + (dolist (state '(nil 0 3 4 6)) + (should (eq (battery--upower-state `(("State" . ,state)) 'pending-discharge) + 'pending-discharge))) + ;; Empty. + (dolist (total '(nil empty)) + (should (eq (battery--upower-state '(("State" . 3)) total) 'empty))) + (dolist (state '(nil 0 3)) + (should (eq (battery--upower-state `(("State" . ,state)) 'empty) 'empty))) + ;; Fully charged. + (dolist (total '(nil fully-charged)) + (should (eq (battery--upower-state '(("State" . 4)) total) 'fully-charged))) + (dolist (state '(nil 0 4)) + (should (eq (battery--upower-state `(("State" . ,state)) 'fully-charged) + 'fully-charged)))) + +(ert-deftest battery-upower-state-unknown () + "Test `battery--upower-state' with unknown states." + ;; Unknown running total retains new state. + (should-not (battery--upower-state () nil)) + (should-not (battery--upower-state '(("State" . state)) nil)) + (should-not (battery--upower-state '(("State" . 0)) nil)) + (should (eq (battery--upower-state '(("State" . 1)) nil) 'charging)) + (should (eq (battery--upower-state '(("State" . 2)) nil) 'discharging)) + (should (eq (battery--upower-state '(("State" . 3)) nil) 'empty)) + (should (eq (battery--upower-state '(("State" . 4)) nil) 'fully-charged)) + (should (eq (battery--upower-state '(("State" . 5)) nil) 'pending-charge)) + (should (eq (battery--upower-state '(("State" . 6)) nil) 'pending-discharge)) + ;; Unknown new state retains running total. + (dolist (props '(() (("State" . state)) (("State" . 0)))) + (dolist (total '(nil charging discharging empty fully-charged + pending-charge pending-discharge)) + (should (eq (battery--upower-state props total) total)))) + ;; Conflicting empty and fully-charged. + (should-not (battery--upower-state '(("State" . 3)) 'fully-charged)) + (should-not (battery--upower-state '(("State" . 4)) 'empty))) + (ert-deftest battery-format () "Test `battery-format'." (should (equal (battery-format "" ()) "")) (should (equal (battery-format "" '((?b . "-"))) "")) - (should (equal (battery-format "%a%b%p%%" '((?b . "-") (?p . "99"))) - "-99%"))) + (should (equal (battery-format "%2a%-3b%.1p%%" '((?b . "-") (?p . "99"))) + "- 9%"))) ;;; battery-tests.el ends here diff --git a/test/lisp/bookmark-tests.el b/test/lisp/bookmark-tests.el index 7e0384b7241..b9c6ff9c542 100644 --- a/test/lisp/bookmark-tests.el +++ b/test/lisp/bookmark-tests.el @@ -25,6 +25,7 @@ (require 'ert) (require 'bookmark) +(require 'cl-lib) (defvar bookmark-tests-data-dir (file-truename @@ -339,21 +340,21 @@ testing `bookmark-bmenu-list'." ,@body) (kill-buffer bookmark-bmenu-buffer))))) -(ert-deftest bookmark-bmenu.enu-edit-annotation/show-annotation () +(ert-deftest bookmark-test-bmenu-edit-annotation/show-annotation () (with-bookmark-bmenu-test (bookmark-set-annotation "name" "foo") (bookmark-bmenu-edit-annotation) (should (string-match "foo" (buffer-string))) (kill-buffer (current-buffer)))) -(ert-deftest bookmark-bmenu-send-edited-annotation () +(ert-deftest bookmark-test-bmenu-send-edited-annotation () (with-bookmark-bmenu-test (bookmark-bmenu-edit-annotation) (insert "foo") (bookmark-send-edited-annotation) (should (equal (bookmark-get-annotation "name") "foo")))) -(ert-deftest bookmark-bmenu-send-edited-annotation/restore-focus () +(ert-deftest bookmark-test-bmenu-send-edited-annotation/restore-focus () "Test for https://debbugs.gnu.org/20150 ." (with-bookmark-bmenu-test (bookmark-bmenu-edit-annotation) @@ -362,5 +363,73 @@ testing `bookmark-bmenu-list'." (should (equal (buffer-name (current-buffer)) bookmark-bmenu-buffer)) (should (looking-at "name")))) +(ert-deftest bookmark-test-bmenu-toggle-filenames () + (with-bookmark-bmenu-test + (should (re-search-forward "/some/file" nil t)) + (bookmark-bmenu-toggle-filenames) + (goto-char (point-min)) + (should-not (re-search-forward "/some/file" nil t)))) + +(ert-deftest bookmark-test-bmenu-toggle-filenames/show () + (with-bookmark-bmenu-test + (bookmark-bmenu-toggle-filenames t) + (should (re-search-forward "/some/file")))) + +(ert-deftest bookmark-test-bmenu-show-filenames () + (with-bookmark-bmenu-test + (bookmark-bmenu-show-filenames) + (should (re-search-forward "/some/file")))) + +(ert-deftest bookmark-test-bmenu-hide-filenames () + (with-bookmark-bmenu-test + (bookmark-bmenu-hide-filenames) + (goto-char (point-min)) + (should-not (re-search-forward "/some/file" nil t)))) + +(ert-deftest bookmark-test-bmenu-bookmark () + (with-bookmark-bmenu-test + (should (equal (bookmark-bmenu-bookmark) "name")))) + +(ert-deftest bookmark-test-bmenu-mark () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (beginning-of-line) + (should (looking-at "^>")))) + +(ert-deftest bookmark-test-bmenu-any-marks () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (beginning-of-line) + (should (bookmark-bmenu-any-marks)))) + +(ert-deftest bookmark-test-bmenu-unmark () + (with-bookmark-bmenu-test + (bookmark-bmenu-mark) + (goto-char (point-min)) + (bookmark-bmenu-unmark) + (beginning-of-line) + (should (looking-at "^ ")))) + +(ert-deftest bookmark-test-bmenu-delete () + (with-bookmark-bmenu-test + (bookmark-bmenu-delete) + (bookmark-bmenu-execute-deletions) + (should (equal (length bookmark-alist) 0)))) + +(ert-deftest bookmark-test-bmenu-locate () + (let (msg) + (cl-letf (((symbol-function 'message) + (lambda (&rest args) + (setq msg (apply #'format args))))) + (with-bookmark-bmenu-test + (bookmark-bmenu-locate) + (should (equal msg "/some/file")))))) + +(ert-deftest bookmark-test-bmenu-filter-alist-by-regexp () + (with-bookmark-bmenu-test + (bookmark-bmenu-filter-alist-by-regexp regexp-unmatchable) + (goto-char (point-min)) + (should (looking-at "^$")))) + (provide 'bookmark-tests) ;;; bookmark-tests.el ends here diff --git a/test/lisp/calc/calc-tests.el b/test/lisp/calc/calc-tests.el index 6db5426ff6d..c8cb97a8bca 100644 --- a/test/lisp/calc/calc-tests.el +++ b/test/lisp/calc/calc-tests.el @@ -345,6 +345,58 @@ An existing calc stack is reused, otherwise a new one is created." (should (Math-num-integerp '(float 1 0))) (should-not (Math-num-integerp nil))) +(ert-deftest calc-matrix-determinant () + (should (equal (calcFunc-det '(vec (vec 3))) + 3)) + (should (equal (calcFunc-det '(vec (vec 2 3) (vec 6 7))) + -4)) + (should (equal (calcFunc-det '(vec (vec 1 2 3) (vec 4 5 7) (vec 9 6 2))) + 15)) + (should (equal (calcFunc-det '(vec (vec 0 5 7 3) + (vec 0 0 2 0) + (vec 1 2 3 4) + (vec 0 0 0 3))) + 30)) + (should (equal (calcFunc-det '(vec (vec (var a var-a)))) + '(var a var-a))) + (should (equal (calcFunc-det '(vec (vec 2 (var a var-a)) + (vec 7 (var a var-a)))) + '(* -5 (var a var-a)))) + (should (equal (calcFunc-det '(vec (vec 1 0 0 0) + (vec 0 1 0 0) + (vec 0 0 0 1) + (vec 0 0 (var a var-a) 0))) + '(neg (var a var-a))))) + +(ert-deftest calc-gcd () + (should (equal (calcFunc-gcd 3 4) 1)) + (should (equal (calcFunc-gcd 12 15) 3)) + (should (equal (calcFunc-gcd -12 15) 3)) + (should (equal (calcFunc-gcd 12 -15) 3)) + (should (equal (calcFunc-gcd -12 -15) 3)) + (should (equal (calcFunc-gcd 0 5) 5)) + (should (equal (calcFunc-gcd 5 0) 5)) + (should (equal (calcFunc-gcd 0 -5) 5)) + (should (equal (calcFunc-gcd -5 0) 5)) + (should (equal (calcFunc-gcd 0 0) 0)) + (should (equal (calcFunc-gcd 0 '(var x var-x)) + '(calcFunc-abs (var x var-x)))) + (should (equal (calcFunc-gcd '(var x var-x) 0) + '(calcFunc-abs (var x var-x))))) + +(ert-deftest calc-sum-gcd () + ;; sum(gcd(0,n),n,-1,-1) + (should (equal (math-simplify '(calcFunc-sum (calcFunc-gcd 0 (var n var-n)) + (var n var-n) -1 -1)) + 1)) + ;; sum(sum(gcd(n,k),k,-1,1),n,-1,1) + (should (equal (math-simplify + '(calcFunc-sum + (calcFunc-sum (calcFunc-gcd (var n var-n) (var k var-k)) + (var k var-k) -1 1) + (var n var-n) -1 1)) + 8))) + (provide 'calc-tests) ;;; calc-tests.el ends here diff --git a/test/lisp/calendar/cal-julian-tests.el b/test/lisp/calendar/cal-julian-tests.el new file mode 100644 index 00000000000..76118b3d7f5 --- /dev/null +++ b/test/lisp/calendar/cal-julian-tests.el @@ -0,0 +1,72 @@ +;;; cal-julian-tests.el --- tests for calendar/cal-julian.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'cal-julian) + +(ert-deftest cal-julian-test-to-absolute () + (should (equal (calendar-gregorian-from-absolute + (calendar-julian-to-absolute + '(10 25 1917))) + '(11 7 1917)))) + +(ert-deftest cal-julian-test-from-absolute () + (should (equal (calendar-julian-from-absolute + (calendar-absolute-from-gregorian + '(11 7 1917))) + '(10 25 1917)))) + +(ert-deftest cal-julian-test-date-string () + (should (equal (let ((calendar-date-display-form calendar-iso-date-display-form)) + (calendar-julian-date-string '(11 7 1917))) + "1917-10-25"))) + +(defmacro with-cal-julian-test (&rest body) + `(save-window-excursion + (unwind-protect + (progn + (calendar) + ,@body) + (kill-buffer "*Calendar*")))) + +(ert-deftest cal-julian-test-goto-date () + (with-cal-julian-test + (calendar-julian-goto-date '(10 25 1917)) + (should (looking-at "7")))) + +(ert-deftest cal-julian-test-astro-to-and-from-absolute () + (should (= (+ (calendar-astro-to-absolute 0.0) + (calendar-astro-from-absolute 0.0)) + 0.0))) + +(ert-deftest cal-julian-calendar-astro-date-string () + (should (equal (calendar-astro-date-string '(10 25 1917)) "2421527"))) + +(ert-deftest calendar-astro-goto-day-number () + (with-cal-julian-test + (calendar-astro-goto-day-number 2421527) + (backward-char) + (should (looking-at "25")))) + +(provide 'cal-julian-tests) +;;; cal-julian-tests.el ends here diff --git a/test/lisp/calendar/icalendar-tests.el b/test/lisp/calendar/icalendar-tests.el index 986255250dc..d496878205b 100644 --- a/test/lisp/calendar/icalendar-tests.el +++ b/test/lisp/calendar/icalendar-tests.el @@ -1,4 +1,4 @@ -;; icalendar-tests.el --- Test suite for icalendar.el +;; icalendar-tests.el --- Test suite for icalendar.el -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008-2020 Free Software Foundation, Inc. @@ -419,11 +419,11 @@ END:VEVENT "))) (should (string= "SUM sum DES des LOC loc ORG org" (icalendar--format-ical-event event))) - (setq icalendar-import-format (lambda (&rest ignore) + (setq icalendar-import-format (lambda (&rest _ignore) "helloworld")) (should (string= "helloworld" (icalendar--format-ical-event event))) (setq icalendar-import-format - (lambda (e) + (lambda (event) (format "-%s-%s-%s-%s-%s-%s-%s-" (icalendar--get-event-property event 'SUMMARY) (icalendar--get-event-property event 'DESCRIPTION) @@ -465,8 +465,7 @@ END:VEVENT (ert-deftest icalendar--decode-isodatetime () "Test `icalendar--decode-isodatetime'." - (let ((tz (getenv "TZ")) - result) + (let ((tz (getenv "TZ"))) (unwind-protect (progn ;; Use Eastern European Time (UTC+2, UTC+3 daylight saving) @@ -886,7 +885,7 @@ During import test the timezone is set to Central European Time." (icalendar-tests--do-test-import input expected-american))))) (setenv "TZ" timezone)))) -(defun icalendar-tests--do-test-import (input expected-output) +(defun icalendar-tests--do-test-import (_input expected-output) "Actually perform import test. Argument INPUT input icalendar string. Argument EXPECTED-OUTPUT expected diary string." @@ -2347,7 +2346,7 @@ END:VCALENDAR (let ((time (icalendar--decode-isodatetime string day zone))) (format-time-string "%FT%T%z" (encode-time time) 0))) -(defun icalendar-tests--decode-isodatetime (ical-string) +(defun icalendar-tests--decode-isodatetime (_ical-string) (should (equal (icalendar-test--format "20040917T050910-0200") "2004-09-17T03:09:10+0000")) (should (equal (icalendar-test--format "20040917T050910") diff --git a/test/lisp/calendar/iso8601-tests.el b/test/lisp/calendar/iso8601-tests.el index 430680c5077..c835f5792b9 100644 --- a/test/lisp/calendar/iso8601-tests.el +++ b/test/lisp/calendar/iso8601-tests.el @@ -24,49 +24,61 @@ (ert-deftest test-iso8601-date-years () (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil -1 nil))) (should (equal (iso8601-parse-date "-0003") - '(nil nil nil nil nil -3 nil nil nil))) + '(nil nil nil nil nil -3 nil -1 nil))) (should (equal (iso8601-parse-date "+1985") - '(nil nil nil nil nil 1985 nil nil nil)))) + '(nil nil nil nil nil 1985 nil -1 nil)))) (ert-deftest test-iso8601-date-dates () (should (equal (iso8601-parse-date "1985-03-14") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil -1 nil))) (should (equal (iso8601-parse-date "19850314") - '(nil nil nil 14 3 1985 nil nil nil))) + '(nil nil nil 14 3 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-02") - '(nil nil nil nil 2 1985 nil nil nil)))) + '(nil nil nil nil 2 1985 nil -1 nil)))) (ert-deftest test-iso8601-date-obsolete () (should (equal (iso8601-parse-date "--02-01") - '(nil nil nil 1 2 nil nil nil nil))) + '(nil nil nil 1 2 nil nil -1 nil))) (should (equal (iso8601-parse-date "--0201") - '(nil nil nil 1 2 nil nil nil nil)))) + '(nil nil nil 1 2 nil nil -1 nil)))) + +(ert-deftest test-iso8601-date-obsolete-2000 () + ;; These are forms in 5.2.1.3 of the 2000 version of the standard, + ;; e) and f). + (should (equal (iso8601-parse-date "--12") + '(nil nil nil nil 12 nil nil -1 nil))) + (should (equal (iso8601-parse "--12T14") + '(0 0 14 nil 12 nil nil -1 nil))) + (should (equal (iso8601-parse-date "---12") + '(nil nil nil 12 nil nil nil -1 nil))) + (should (equal (iso8601-parse "---12T14:10:12") + '(12 10 14 12 nil nil nil -1 nil)))) (ert-deftest test-iso8601-date-weeks () (should (equal (iso8601-parse-date "2008W39-6") - '(nil nil nil 27 9 2008 nil nil nil))) + '(nil nil nil 27 9 2008 nil -1 nil))) (should (equal (iso8601-parse-date "2009W01-1") - '(nil nil nil 29 12 2008 nil nil nil))) + '(nil nil nil 29 12 2008 nil -1 nil))) (should (equal (iso8601-parse-date "2009W53-7") - '(nil nil nil 3 1 2010 nil nil nil)))) + '(nil nil nil 3 1 2010 nil -1 nil)))) (ert-deftest test-iso8601-date-ordinals () (should (equal (iso8601-parse-date "1981-095") - '(nil nil nil 5 4 1981 nil nil nil)))) + '(nil nil nil 5 4 1981 nil -1 nil)))) (ert-deftest test-iso8601-time () (should (equal (iso8601-parse-time "13:47:30") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "134730") - '(30 47 13 nil nil nil nil nil nil))) + '(30 47 13 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "1347") - '(0 47 13 nil nil nil nil nil nil)))) + '(0 47 13 nil nil nil nil -1 nil)))) (ert-deftest test-iso8601-combined () (should (equal (iso8601-parse "2008-03-02T13:47:30") - '(30 47 13 2 3 2008 nil nil nil))) + '(30 47 13 2 3 2008 nil -1 nil))) (should (equal (iso8601-parse "2008-03-02T13:47:30Z") '(30 47 13 2 3 2008 nil nil 0))) (should (equal (iso8601-parse "2008-03-02T13:47:30+01:00") @@ -76,13 +88,13 @@ (ert-deftest test-iso8601-duration () (should (equal (iso8601-parse-duration "P3Y6M4DT12H30M5S") - '(5 30 12 4 6 3 nil nil nil))) + '(5 30 12 4 6 3 nil -1 nil))) (should (equal (iso8601-parse-duration "P1M") - '(0 0 0 0 1 0 nil nil nil))) + '(0 0 0 0 1 0 nil -1 nil))) (should (equal (iso8601-parse-duration "PT1M") - '(0 1 0 0 0 0 nil nil nil))) + '(0 1 0 0 0 0 nil -1 nil))) (should (equal (iso8601-parse-duration "P0003-06-04T12:30:05") - '(5 30 12 4 6 3 nil nil nil)))) + '(5 30 12 4 6 3 nil -1 nil)))) (ert-deftest test-iso8601-invalid () (should-not (iso8601-valid-p " 2008-03-02T13:47:30-01")) @@ -101,88 +113,88 @@ (should (equal (iso8601-parse-interval "2007-03-01T13:00:00Z/P1Y2M10DT2H30M") '((0 0 13 1 3 2007 nil nil 0) (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil)))) + (0 30 2 10 2 1 nil -1 nil)))) (should (equal (iso8601-parse-interval "P1Y2M10DT2H30M/2008-05-11T15:30:00Z") '((0 0 13 1 3 2007 nil nil 0) (0 30 15 11 5 2008 nil nil 0) - (0 30 2 10 2 1 nil nil nil))))) + (0 30 2 10 2 1 nil -1 nil))))) (ert-deftest standard-test-dates () (should (equal (iso8601-parse-date "19850412") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-102") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985W155") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-W15-5") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-W15") - '(nil nil nil 7 4 1985 nil nil nil))) + '(nil nil nil 7 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985-04") - '(nil nil nil nil 4 1985 nil nil nil))) + '(nil nil nil nil 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "1985") - '(nil nil nil nil nil 1985 nil nil nil))) + '(nil nil nil nil nil 1985 nil -1 nil))) (should (equal (iso8601-parse-date "+1985-04-12") - '(nil nil nil 12 4 1985 nil nil nil))) + '(nil nil nil 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse-date "+19850412") - '(nil nil nil 12 4 1985 nil nil nil)))) + '(nil nil nil 12 4 1985 nil -1 nil)))) (ert-deftest standard-test-time-of-day-local-time () (should (equal (iso8601-parse-time "152746") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:46") - '(46 27 15 nil nil nil nil nil nil))) + '(46 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "1528") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:28") - '(0 28 15 nil nil nil nil nil nil))) + '(0 28 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15") - '(0 0 15 nil nil nil nil nil nil)))) + '(0 0 15 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-fractions () (should (equal (iso8601-parse-time "152735,5" t) - '((355 . 10) 27 15 nil nil nil nil nil nil))) + '((355 . 10) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:35,5" t) - '((355 . 10) 27 15 nil nil nil nil nil nil))) + '((355 . 10) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "2320,5" t) - '(30 20 23 nil nil nil nil nil nil))) + '(30 20 23 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "23:20,8" t) - '(48 20 23 nil nil nil nil nil nil))) + '(48 20 23 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "23,3" t) - '(0 18 23 nil nil nil nil nil nil)))) + '(0 18 23 nil nil nil nil -1 nil)))) (ert-deftest nonstandard-test-time-of-day-decimals () (should (equal (iso8601-parse-time "15:27:35.123" t) - '((35123 . 1000) 27 15 nil nil nil nil nil nil))) + '((35123 . 1000) 27 15 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "15:27:35.123456789" t) - '((35123456789 . 1000000000) 27 15 nil nil nil nil nil nil)))) + '((35123456789 . 1000000000) 27 15 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-beginning-of-day () (should (equal (iso8601-parse-time "000000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "00:00:00") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "0000") - '(0 0 0 nil nil nil nil nil nil))) + '(0 0 0 nil nil nil nil -1 nil))) (should (equal (iso8601-parse-time "00:00") - '(0 0 0 nil nil nil nil nil nil)))) + '(0 0 0 nil nil nil nil -1 nil)))) (ert-deftest standard-test-time-of-day-utc () (should (equal (iso8601-parse-time "232030Z") @@ -220,11 +232,42 @@ (should (equal (iso8601-parse-time "15:27:46-05") '(46 27 15 nil nil nil nil nil -18000)))) + +(defun test-iso8601-format-time-string-zone-round-trip (offset-minutes z-format) + "Pass OFFSET-MINUTES to format-time-string with Z-FORMAT, a %z variation, +and then to iso8601-parse-zone. The result should be the original offset." + (let* ((offset-seconds (* 60 offset-minutes)) + (zone-string (format-time-string z-format 0 offset-seconds)) + (offset-rt + (condition-case nil + (iso8601-parse-zone zone-string) + (wrong-type-argument (format "(failed to parse %S)" zone-string)))) + ;; compare strings that contain enough info to debug failures + (success (format "%s(%s) -> %S -> %s" + z-format offset-minutes zone-string offset-minutes)) + (actual (format "%s(%s) -> %S -> %s" + z-format offset-minutes zone-string offset-rt))) + (should (equal success actual)))) + +(ert-deftest iso8601-format-time-string-zone-round-trip () + "Round trip zone offsets through format-time-string and iso8601-parse-zone. +Passing a time zone created by format-time-string %z to +iso8601-parse-zone should yield the original offset." + (dolist (offset-minutes + (list + ;; compare hours (1- and 2-digit), minutes, both, neither + (* 5 60) (* 11 60) 5 11 (+ (* 5 60) 30) (+ (* 11 60) 30) 0 + ;; do negative values, too + (* -5 60) (* -11 60) -5 -11 (- (* -5 60) 30) (- (* -11 60) 30))) + (dolist (z-format '("%z" "%:z" "%:::z")) + (test-iso8601-format-time-string-zone-round-trip + offset-minutes z-format)))) + (ert-deftest standard-test-date-and-time-of-day () (should (equal (iso8601-parse "19850412T101530") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985-04-12T10:15:30") - '(30 15 10 12 4 1985 nil nil nil))) + '(30 15 10 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985102T235030Z") '(30 50 23 12 4 1985 nil nil 0))) @@ -232,9 +275,9 @@ '(30 50 23 12 4 1985 nil nil 0))) (should (equal (iso8601-parse "1985W155T235030") - '(30 50 23 12 4 1985 nil nil nil))) + '(30 50 23 12 4 1985 nil -1 nil))) (should (equal (iso8601-parse "1985-W155T23:50:30") - '(30 50 23 12 4 1985 nil nil nil)))) + '(30 50 23 12 4 1985 nil -1 nil)))) (ert-deftest standard-test-interval () ;; A time interval starting at 20 minutes and 50 seconds past 23 @@ -256,48 +299,48 @@ ;; This example doesn't seem valid according to the standard. ;; "0625" is unambiguous, and means "the year 625". Weird. ;; (should (equal (iso8601-parse-interval "19850412/0625") - ;; '((nil nil nil 12 4 1985 nil nil nil) - ;; (nil nil nil nil nil 625 nil nil nil) + ;; '((nil nil nil 12 4 1985 nil -1 nil) + ;; (nil nil nil nil nil 625 nil -1 nil) ;; (0 17 0 22 9 609 5 nil 0)))) ;; A time interval of 2 years, 10 months, 15 days, 10 hours, 20 ;; minutes and 30 seconds. (should (equal (iso8601-parse-duration "P2Y10M15DT10H20M30S") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) (should (equal (iso8601-parse-duration "P00021015T102030") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) (should (equal (iso8601-parse-duration "P0002-10-15T10:20:30") - '(30 20 10 15 10 2 nil nil nil))) + '(30 20 10 15 10 2 nil -1 nil))) ;; A time interval of 1 year and 6 months. (should (equal (iso8601-parse-duration "P1Y6M") - '(0 0 0 0 6 1 nil nil nil))) + '(0 0 0 0 6 1 nil -1 nil))) (should (equal (iso8601-parse-duration "P0001-06") - '(nil nil nil nil 6 1 nil nil nil))) + '(nil nil nil nil 6 1 nil -1 nil))) ;; A time interval of seventy-two hours. (should (equal (iso8601-parse-duration "PT72H") - '(0 0 72 0 0 0 nil nil nil))) + '(0 0 72 0 0 0 nil -1 nil))) ;; Defined by start and duration ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ;; beginning on 12 April 1985 at 20 minutes past 23 hours. (should (equal (iso8601-parse-interval "19850412T232000/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil -1 nil) + (0 20 11 28 6 1986 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil)))) (should (equal (iso8601-parse-interval "1985-04-12T23:20:00/P1Y2M15DT12H") - '((0 20 23 12 4 1985 nil nil nil) - (0 20 11 28 6 1986 nil nil nil) - (0 0 12 15 2 1 nil nil nil)))) + '((0 20 23 12 4 1985 nil -1 nil) + (0 20 11 28 6 1986 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil)))) ;; Defined by duration and end ;; A time interval of 1 year, 2 months, 15 days and 12 hours, ending ;; on 12 April 1985 at 20 minutes past 23 hour. (should (equal (iso8601-parse-interval "P1Y2M15DT12H/19850412T232000") - '((0 20 11 28 1 1984 nil nil nil) - (0 20 23 12 4 1985 nil nil nil) - (0 0 12 15 2 1 nil nil nil))))) + '((0 20 11 28 1 1984 nil -1 nil) + (0 20 23 12 4 1985 nil -1 nil) + (0 0 12 15 2 1 nil -1 nil))))) ;;; iso8601-tests.el ends here diff --git a/test/lisp/calendar/lunar-tests.el b/test/lisp/calendar/lunar-tests.el new file mode 100644 index 00000000000..d2647aac03a --- /dev/null +++ b/test/lisp/calendar/lunar-tests.el @@ -0,0 +1,75 @@ +;;; lunar-tests.el --- tests for calendar/lunar.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'lunar) + +(defmacro with-lunar-test (&rest body) + `(let ((calendar-latitude 40.1) + (calendar-longitude -88.2) + (calendar-location-name "Urbana, IL") + (calendar-time-zone -360) + (calendar-standard-time-zone-name "CST") + (calendar-time-display-form '(12-hours ":" minutes am-pm))) + ,@body)) + +(ert-deftest lunar-test-phase () + (with-lunar-test + (should (equal (lunar-phase 1) + '((1 7 1900) "11:40pm" 1 ""))))) + +(ert-deftest lunar-test-eclipse-check () + (with-lunar-test + (should (equal (eclipse-check 1 1) "** Eclipse **")))) + +;; This fails in certain time zones. +;; Eg TZ=America/Phoenix make lisp/calendar/lunar-tests +;; Similarly with TZ=UTC. +;; Daylight saving related? +(ert-deftest lunar-test-phase-list () + :tags '(:unstable) + (with-lunar-test + (should (equal (lunar-phase-list 3 1871) + '(((3 20 1871) "11:03pm" 0 "") + ((3 29 1871) "1:46am" 1 "** Eclipse **") + ((4 5 1871) "9:20am" 2 "") + ((4 12 1871) "12:57am" 3 "** Eclipse possible **") + ((4 19 1871) "2:06pm" 0 "") + ((4 27 1871) "6:49pm" 1 "") + ((5 4 1871) "5:57pm" 2 "") + ((5 11 1871) "9:29am" 3 "") + ((5 19 1871) "5:46am" 0 "") + ((5 27 1871) "8:02am" 1 "")))))) + +(ert-deftest lunar-test-new-moon-time () + (with-lunar-test + (should (= (round (lunar-new-moon-time 1)) + 2451580)))) + +(ert-deftest lunar-test-new-moon-on-or-after () + (with-lunar-test + (should (= (round (lunar-new-moon-on-or-after (calendar-absolute-from-gregorian '(5 5 1818)))) + 664525)))) + +(provide 'lunar-tests) +;;; lunar-tests.el ends here diff --git a/test/lisp/calendar/parse-time-tests.el b/test/lisp/calendar/parse-time-tests.el index 4924e8b072a..e1801a57307 100644 --- a/test/lisp/calendar/parse-time-tests.el +++ b/test/lisp/calendar/parse-time-tests.el @@ -1,4 +1,4 @@ -;; parse-time-tests.el --- Test suite for parse-time.el +;; parse-time-tests.el --- Test suite for parse-time.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/calendar/time-date-tests.el b/test/lisp/calendar/time-date-tests.el index 4c8f18a7a95..3eecc67eb53 100644 --- a/test/lisp/calendar/time-date-tests.el +++ b/test/lisp/calendar/time-date-tests.el @@ -31,7 +31,9 @@ (ert-deftest test-days-in-month () (should (= (date-days-in-month 2004 2) 29)) (should (= (date-days-in-month 2004 3) 31)) - (should-not (= (date-days-in-month 1900 3) 28))) + (should-not (= (date-days-in-month 1900 3) 28)) + (should-error (date-days-in-month 2020 15)) + (should-error (date-days-in-month 2020 'foo))) (ert-deftest test-ordinal () (should (equal (date-ordinal-to-time 2008 271) diff --git a/test/lisp/cedet/semantic-utest-fmt.el b/test/lisp/cedet/semantic-utest-fmt.el index 2fc2b681868..c2f2bb7226c 100644 --- a/test/lisp/cedet/semantic-utest-fmt.el +++ b/test/lisp/cedet/semantic-utest-fmt.el @@ -1,4 +1,4 @@ -;;; cedet/semantic-utest-fmt.el --- Parsing / Formatting tests +;;; cedet/semantic-utest-fmt.el --- Parsing / Formatting tests -*- lexical-binding:t -*- ;;; Copyright (C) 2003-2004, 2007-2020 Free Software Foundation, Inc. @@ -69,7 +69,6 @@ Files to visit are in `semantic-fmt-utest-file-list'." ;; Run the tests. (let ((fb (find-buffer-visiting fname)) (b (semantic-find-file-noselect fname)) - (num 0) (tags nil)) (save-current-buffer @@ -82,7 +81,6 @@ Files to visit are in `semantic-fmt-utest-file-list'." (semantic-clear-toplevel-cache) ;; Force the reparse (setq tags (semantic-fetch-tags)) - (setq num (length tags)) (save-excursion (while tags diff --git a/test/lisp/cedet/semantic-utest-ia.el b/test/lisp/cedet/semantic-utest-ia.el index 5761224d756..c99ef97b509 100644 --- a/test/lisp/cedet/semantic-utest-ia.el +++ b/test/lisp/cedet/semantic-utest-ia.el @@ -1,4 +1,4 @@ -;;; semantic-utest-ia.el --- Analyzer unit tests +;;; semantic-utest-ia.el --- Analyzer unit tests -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -211,7 +211,7 @@ ;; completions, then remove the below debug-on-error setting. (debug-on-error nil) (acomp - (condition-case err + (condition-case _err (semantic-analyze-possible-completions ctxt) ((error user-error) nil)) )) @@ -438,11 +438,10 @@ tag that contains point, and return that." (let* ((ctxt (semantic-analyze-current-context)) (target (car (reverse (oref ctxt prefix)))) (tag (semantic-current-tag)) - (start (current-time)) (Lcount 0)) (when (semantic-tag-p target) (semantic-symref-hits-in-region - target (lambda (start end prefix) (setq Lcount (1+ Lcount))) + target (lambda (_start _end _prefix) (setq Lcount (1+ Lcount))) (semantic-tag-start tag) (semantic-tag-end tag)) Lcount))) diff --git a/test/lisp/cedet/semantic-utest.el b/test/lisp/cedet/semantic-utest.el index 7e336557948..e537871528c 100644 --- a/test/lisp/cedet/semantic-utest.el +++ b/test/lisp/cedet/semantic-utest.el @@ -1,4 +1,4 @@ -;;; semantic-utest.el --- Tests for semantic's parsing system. +;;; semantic-utest.el --- Tests for semantic's parsing system. -*- lexical-binding:t -*- ;;; Copyright (C) 2003-2004, 2007-2020 Free Software Foundation, Inc. @@ -537,10 +537,9 @@ Pre-fill the buffer with CONTENTS." -(defun semantic-utest-generic (testname filename contents name-contents names-removed killme insertme) +(defun semantic-utest-generic (filename contents name-contents names-removed killme insertme) "Generic unit test according to template. Should work for languages without .h files, python javascript java. -TESTNAME is the name of the test. FILENAME is the name of the file to create. CONTENTS is the contents of the file to test. NAME-CONTENTS is the list of names that should be in the contents. @@ -564,10 +563,8 @@ INSERTME is the text to be inserted after the deletion." (sit-for 0) ;; Run the tests. - ;;(message "First parsing test %s." testname) (should (semantic-utest-verify-names name-contents)) - ;;(message "Invalid tag test %s." testname) (semantic-utest-last-invalid name-contents names-removed killme insertme) (should (semantic-utest-verify-names name-contents)) @@ -576,16 +573,17 @@ INSERTME is the text to be inserted after the deletion." (kill-buffer buff) ))) +(defvar python-indent-guess-indent-offset) ; Silence byte-compiler. (ert-deftest semantic-utest-Python() - (skip-unless (featurep 'python-mode)) + (skip-unless (fboundp 'python-mode)) (let ((python-indent-guess-indent-offset nil)) - (semantic-utest-generic "Python" (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") + (semantic-utest-generic (semantic-utest-fname "pytest.py") semantic-utest-Python-buffer-contents semantic-utest-Python-name-contents '("fun2") "#1" "#deleted line") )) (ert-deftest semantic-utest-Javascript() (if (fboundp 'javascript-mode) - (semantic-utest-generic "Javascript" (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "javascripttest.js") semantic-utest-Javascript-buffer-contents semantic-utest-Javascript-name-contents '("fun2") "//1" "//deleted line") (message "Skipping JavaScript test: NO major mode.")) ) @@ -593,34 +591,34 @@ INSERTME is the text to be inserted after the deletion." ;; If JDE is installed, it might mess things up depending on the version ;; that was installed. (let ((auto-mode-alist '(("\\.java\\'" . java-mode)))) - (semantic-utest-generic "Java" (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "JavaTest.java") semantic-utest-Java-buffer-contents semantic-utest-Java-name-contents '("fun2") "//1" "//deleted line") )) (ert-deftest semantic-utest-Makefile() - (semantic-utest-generic "Makefile" (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") + (semantic-utest-generic (semantic-utest-fname "Makefile") semantic-utest-Makefile-buffer-contents semantic-utest-Makefile-name-contents '("fun2") "#1" "#deleted line") ) (ert-deftest semantic-utest-Scheme() (skip-unless nil) ;; There is a bug w/ scheme parser. Skip this for now. - (semantic-utest-generic "Scheme" (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") + (semantic-utest-generic (semantic-utest-fname "tst.scm") semantic-utest-Scheme-buffer-contents semantic-utest-Scheme-name-contents '("fun2") ";1" ";deleted line") ) - +(defvar html-helper-build-new-buffer) ; Silence byte-compiler. (ert-deftest semantic-utest-Html() ;; Disable html-helper auto-fill-in mode. - (let ((html-helper-build-new-buffer nil)) - (semantic-utest-generic "HTML" (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->") + (let ((html-helper-build-new-buffer nil)) ; FIXME: Why is this bound? + (semantic-utest-generic (semantic-utest-fname "tst.html") semantic-utest-Html-buffer-contents semantic-utest-Html-name-contents '("fun2") "<!--1-->" "<!--deleted line-->") )) (ert-deftest semantic-utest-PHP() (skip-unless (featurep 'php-mode)) - (semantic-utest-generic "PHP" (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") + (semantic-utest-generic (semantic-utest-fname "phptest.php") semantic-utest-PHP-buffer-contents semantic-utest-PHP-name-contents '("fun1") "fun2" "%^@") ) ;look at http://mfgames.com/linux/csharp-mode (ert-deftest semantic-utest-Csharp() ;; hmm i don't even know how to edit a scharp file. need a csharp mode implementation i suppose (skip-unless (featurep 'csharp-mode)) - (semantic-utest-generic "C#" (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") + (semantic-utest-generic (semantic-utest-fname "csharptest.cs") semantic-utest-Csharp-buffer-contents semantic-utest-Csharp-name-contents '("fun2") "//1" "//deleted line") ) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -758,7 +756,7 @@ JAVE this thing would need to be recursive to handle java and csharp" (sit-for 0) ) -(defun semantic-utest-last-invalid (name-contents names-removed killme insertme) +(defun semantic-utest-last-invalid (_name-contents _names-removed killme insertme) "Make the last fcn invalid." (semantic-utest-kill-indicator killme insertme) ; (semantic-utest-verify-names name-contents names-removed); verify its gone ;new validator doesn't handle skipnames yet diff --git a/test/lisp/cedet/srecode-utest-getset.el b/test/lisp/cedet/srecode-utest-getset.el index e49a19594c3..3419b18afb5 100644 --- a/test/lisp/cedet/srecode-utest-getset.el +++ b/test/lisp/cedet/srecode-utest-getset.el @@ -1,4 +1,4 @@ -;;; srecode/test-getset.el --- Test the getset inserter. +;;; srecode/test-getset.el --- Test the getset inserter. -*- lexical-binding:t -*- ;; Copyright (C) 2008, 2009, 2011, 2019-2020 Free Software Foundation, Inc @@ -52,6 +52,7 @@ private: temporary-file-directory) "File used to do testing.") +(defvar srecode-insert-getset-fully-automatic-flag) ; Silence byte-compiler. (ert-deftest srecode-utest-getset-output () "Test various template insertion options." (save-excursion diff --git a/test/lisp/cedet/srecode-utest-template.el b/test/lisp/cedet/srecode-utest-template.el index 4dd64e2ea8c..63c33a3c440 100644 --- a/test/lisp/cedet/srecode-utest-template.el +++ b/test/lisp/cedet/srecode-utest-template.el @@ -1,4 +1,4 @@ -;;; srecode/test.el --- SRecode Core Template tests. +;;; srecode/test.el --- SRecode Core Template tests. -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. diff --git a/test/lisp/comint-tests.el b/test/lisp/comint-tests.el index 9c27a92d2bf..132fe875f72 100644 --- a/test/lisp/comint-tests.el +++ b/test/lisp/comint-tests.el @@ -1,4 +1,4 @@ -;;; comint-testsuite.el +;;; comint-tests.el -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. diff --git a/test/lisp/custom-resources/custom--test-theme.el b/test/lisp/custom-resources/custom--test-theme.el index da9121e0a0a..4ced98a50bc 100644 --- a/test/lisp/custom-resources/custom--test-theme.el +++ b/test/lisp/custom-resources/custom--test-theme.el @@ -1,3 +1,5 @@ +;;; custom--test-theme.el -- A test theme. -*- lexical-binding:t -*- + (deftheme custom--test "A test theme.") diff --git a/test/lisp/dabbrev-tests.el b/test/lisp/dabbrev-tests.el index 0a2f67e91c7..06c5c0655a7 100644 --- a/test/lisp/dabbrev-tests.el +++ b/test/lisp/dabbrev-tests.el @@ -1,4 +1,4 @@ -;;; dabbrev-tests.el --- Test suite for dabbrev. +;;; dabbrev-tests.el --- Test suite for dabbrev. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/descr-text-tests.el b/test/lisp/descr-text-tests.el index 74fcdf5af37..b060dffb0ff 100644 --- a/test/lisp/descr-text-tests.el +++ b/test/lisp/descr-text-tests.el @@ -75,18 +75,18 @@ (goto-char (point-min)) (should (eq ?a (following-char))) ; make sure we are where we think we are ;; Function should return nil for an ASCII character. - (should (not (describe-char-eldoc))) + (should (not (describe-char-eldoc 'ignore))) (goto-char (1+ (point))) (should (eq ?… (following-char))) (let ((eldoc-echo-area-use-multiline-p t)) ;; Function should return description of an Unicode character. (should (equal "U+2026: Horizontal ellipsis (Po: Punctuation, Other)" - (describe-char-eldoc)))) + (describe-char-eldoc 'ignore)))) (goto-char (point-max)) ;; At the end of the buffer, function should return nil and not blow up. - (should (not (describe-char-eldoc))))) + (should (not (describe-char-eldoc 'ignore))))) (provide 'descr-text-test) diff --git a/test/lisp/dom-tests.el b/test/lisp/dom-tests.el index d44851eb13b..f743df78fd5 100644 --- a/test/lisp/dom-tests.el +++ b/test/lisp/dom-tests.el @@ -84,6 +84,13 @@ (dom-set-attribute dom attr value) (should (equal (dom-attr dom attr) value)))) +(ert-deftest dom-tests-remove-attribute () + (let ((dom (copy-tree '(body ((foo . "bar") (zot . "foobar")))))) + (should (equal (dom-attr dom 'foo) "bar")) + (dom-remove-attribute dom 'foo) + (should (equal (dom-attr dom 'foo) nil)) + (should (equal dom '(body ((zot . "foobar"))))))) + (ert-deftest dom-tests-attr () (let ((dom (dom-tests--tree))) (should-not (dom-attr dom 'id)) diff --git a/test/lisp/electric-tests.el b/test/lisp/electric-tests.el index 56d1bdb110e..67f474cbd52 100644 --- a/test/lisp/electric-tests.el +++ b/test/lisp/electric-tests.el @@ -547,6 +547,24 @@ baz\"\"" (should (equal "" (buffer-string)))))) +;;; Undoing +(ert-deftest electric-pair-undo-unrelated-state () + "Make sure `electric-pair-mode' does not confuse `undo' (bug#39680)." + (with-temp-buffer + (buffer-enable-undo) + (electric-pair-local-mode) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (let ((last-command-event ?a)) + (ert-simulate-command '(self-insert-command 1))) + (undo-boundary) + (ert-simulate-command '(undo)) + (let ((last-command-event ?\()) + (ert-simulate-command '(self-insert-command 1))) + (should (string= (buffer-string) "(())")))) + + ;;; Electric newlines between pairs ;;; TODO: better tests (ert-deftest electric-pair-open-extra-newline () diff --git a/test/lisp/elide-head-tests.el b/test/lisp/elide-head-tests.el new file mode 100644 index 00000000000..c9ef26a8181 --- /dev/null +++ b/test/lisp/elide-head-tests.el @@ -0,0 +1,62 @@ +;;; elide-head-tests.el --- Tests for elide-head.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'elide-head) +(require 'ert) + +(ert-deftest elide-head-tests-elide-head () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (let ((o (car (overlays-at 14)))) + (should (= (overlay-start o) 10)) + (should (= (overlay-end o) 21)) + (should (overlay-get o 'invisible)) + (should (overlay-get o 'evaporate)))))) + +(ert-deftest elide-head-tests-elide-head-with-prefix-arg () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (should (overlays-at 14)) + (elide-head t) + (should-not (overlays-at 14))))) + +(ert-deftest elide-head-tests-show () + (let ((elide-head-headers-to-hide '(("START" . "END")))) + (with-temp-buffer + (insert "foo\nSTART\nHIDDEN\nEND\nbar") + (elide-head) + (should (overlays-at 14)) + (elide-head-show) + (should-not (overlays-at 14))))) + +(provide 'elide-head-tests) +;;; elide-head-tests.el ends here diff --git a/test/lisp/emacs-lisp/bindat-tests.el b/test/lisp/emacs-lisp/bindat-tests.el index f8efa7902a4..14f95a8bf80 100644 --- a/test/lisp/emacs-lisp/bindat-tests.el +++ b/test/lisp/emacs-lisp/bindat-tests.el @@ -96,4 +96,20 @@ (dest-ip . [192 168 1 100])))))) +(ert-deftest bindat-test-format-vector () + (should (equal (bindat-format-vector [1 2 3] "%d" "x" 2) "1x2")) + (should (equal (bindat-format-vector [1 2 3] "%d" "x") "1x2x3"))) + +(ert-deftest bindat-test-vector-to-dec () + (should (equal (bindat-vector-to-dec [1 2 3]) "1.2.3")) + (should (equal (bindat-vector-to-dec [2048 1024 512] ".") "2048.1024.512"))) + +(ert-deftest bindat-test-vector-to-hex () + (should (equal (bindat-vector-to-hex [1 2 3]) "01:02:03")) + (should (equal (bindat-vector-to-hex [2048 1024 512] ".") "800.400.200"))) + +(ert-deftest bindat-test-ip-to-string () + (should (equal (bindat-ip-to-string [192 168 0 1]) "192.168.0.1")) + (should (equal (bindat-ip-to-string "\300\250\0\1") "192.168.0.1"))) + ;;; bindat-tests.el ends here diff --git a/test/lisp/emacs-lisp/bytecomp-tests.el b/test/lisp/emacs-lisp/bytecomp-tests.el index a16adfedfb8..c235dd43fcc 100644 --- a/test/lisp/emacs-lisp/bytecomp-tests.el +++ b/test/lisp/emacs-lisp/bytecomp-tests.el @@ -1,4 +1,4 @@ -;;; bytecomp-tests.el +;;; bytecomp-tests.el -*- lexical-binding:t -*- ;; Copyright (C) 2008-2020 Free Software Foundation, Inc. @@ -347,7 +347,12 @@ ((eq x 't) 99) (t 999)))) '((a c) (b c) (7 c) (-3 c) (nil nil) (t c) (q c) (r c) (s c) - (t c) (x "a") (x "c") (x c) (x d) (x e)))) + (t c) (x "a") (x "c") (x c) (x d) (x e))) + + ;; `substring' bytecode generation (bug#39709). + (substring "abcdef") + (substring "abcdef" 2) + (substring "abcdef" 3 2)) "List of expression for test. Each element will be executed by interpreter and with bytecompiled code, and their results compared.") @@ -358,10 +363,10 @@ bytecompiled code, and their results compared.") (byte-compile-warnings nil) (v0 (condition-case nil (eval pat) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error 'bytecomp-check-error)))) (equal v0 v1))) (put 'bytecomp-check-1 'ert-explainer 'bytecomp-explain-1) @@ -369,10 +374,10 @@ bytecompiled code, and their results compared.") (defun bytecomp-explain-1 (pat) (let ((v0 (condition-case nil (eval pat) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (byte-compile (list 'lambda nil pat))) - (error nil)))) + (error 'bytecomp-check-error)))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -397,10 +402,10 @@ Subtests signal errors if something goes wrong." (dolist (pat byte-opt-testsuite-arith-data) (condition-case nil (setq v0 (eval pat)) - (error (setq v0 nil))) + (error (setq v0 'bytecomp-check-error))) (condition-case nil (setq v1 (funcall (byte-compile (list 'lambda nil pat)))) - (error (setq v1 nil))) + (error (setq v1 'bytecomp-check-error))) (insert (format "%s" pat)) (indent-to-column 65) (if (equal v0 v1) @@ -556,11 +561,11 @@ bytecompiled code, and their results compared.") (byte-compile-warnings nil) (v0 (condition-case nil (eval pat t) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (let ((lexical-binding t)) (byte-compile `(lambda nil ,pat)))) - (error nil)))) + (error 'bytecomp-check-error)))) (equal v0 v1))) (put 'bytecomp-lexbind-check-1 'ert-explainer 'bytecomp-lexbind-explain-1) @@ -568,11 +573,11 @@ bytecompiled code, and their results compared.") (defun bytecomp-lexbind-explain-1 (pat) (let ((v0 (condition-case nil (eval pat t) - (error nil))) + (error 'bytecomp-check-error))) (v1 (condition-case nil (funcall (let ((lexical-binding t)) (byte-compile (list 'lambda nil pat)))) - (error nil)))) + (error 'bytecomp-check-error)))) (format "Expression `%s' gives `%s' if directly evalled, `%s' if compiled." pat v0 v1))) @@ -615,17 +620,6 @@ literals (Bug#20852)." (let ((byte-compile-dest-file-function (lambda (_) destination))) (should (byte-compile-file source))))))) -(ert-deftest bytecomp-tests--old-style-backquotes () - "Check that byte compiling warns about old-style backquotes." - (bytecomp-tests--with-temp-file source - (write-region "(` (a b))" nil source) - (bytecomp-tests--with-temp-file destination - (let* ((byte-compile-dest-file-function (lambda (_) destination)) - (byte-compile-debug t) - (err (should-error (byte-compile-file source)))) - (should (equal (cdr err) '("Old-style backquotes detected!"))))))) - - (ert-deftest bytecomp-tests-function-put () "Check `function-put' operates during compilation." (bytecomp-tests--with-temp-file source diff --git a/test/lisp/emacs-lisp/check-declare-tests.el b/test/lisp/emacs-lisp/check-declare-tests.el new file mode 100644 index 00000000000..bb9542114c4 --- /dev/null +++ b/test/lisp/emacs-lisp/check-declare-tests.el @@ -0,0 +1,116 @@ +;;; check-declare-tests.el --- Tests for check-declare.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'check-declare) +(require 'ert) +(eval-when-compile (require 'subr-x)) + +(ert-deftest check-declare-tests-locate () + (should (file-exists-p (check-declare-locate "check-declare" ""))) + (should + (string-prefix-p "ext:" (check-declare-locate "ext:foo" "")))) + +(ert-deftest check-declare-tests-scan () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(declare-function ring-insert \"ring\" (ring item))" + "(let ((foo 'code)) foo)") + "\n"))) + (let ((res (check-declare-scan file))) + (should (= (length res) 1)) + (pcase-let ((`((,fnfile ,fn ,arglist ,fileonly)) res)) + (should (string-match-p "ring" fnfile)) + (should (equal "ring-insert" fn)) + (should (equal '(ring item) arglist)) + (should-not fileonly)))) + (delete-file file)))) + +(ert-deftest check-declare-tests-verify () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring item)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should-not + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))))) + (delete-file file)))) + +(ert-deftest check-declare-tests-verify-mismatch () + (let ((file (make-temp-file "check-declare-tests-"))) + (unwind-protect + (progn + (with-temp-file file + (insert + (string-join + '(";; foo comment" + "(defun foo-fun ())" + "(defun ring-insert (ring)" + "\"Insert onto ring RING the item ITEM.\"" + "nil)") + "\n"))) + (should + (equal + (check-declare-verify + file '(("foo.el" "ring-insert" (ring item)))) + '(("foo.el" "ring-insert" "arglist mismatch"))))) + (delete-file file)))) + +(ert-deftest check-declare-tests-sort () + (should-not (check-declare-sort '())) + (should (equal (check-declare-sort '((a (1 a)) (b (2)) (d (1 d)))) + '((2 (b)) (1 (a a) (d d)))))) + +(ert-deftest check-declare-tests-warn () + (with-temp-buffer + (let ((check-declare-warning-buffer (buffer-name))) + (check-declare-warn + "foo-file" "foo-fun" "bar-file" "it wasn't" 999) + (let ((res (buffer-string))) + ;; Don't care too much about the format of the output, but + ;; check that key information is present. + (should (string-match-p "foo-file" res)) + (should (string-match-p "foo-fun" res)) + (should (string-match-p "bar-file" res)) + (should (string-match-p "it wasn't" res)) + (should (string-match-p "999" res)))))) + +(provide 'check-declare-tests) +;;; check-declare-tests.el ends here diff --git a/test/lisp/emacs-lisp/cl-macs-tests.el b/test/lisp/emacs-lisp/cl-macs-tests.el index c357ecde951..29ae95e2771 100644 --- a/test/lisp/emacs-lisp/cl-macs-tests.el +++ b/test/lisp/emacs-lisp/cl-macs-tests.el @@ -39,6 +39,15 @@ collect (list c b a)) '((4.0 2 1) (8.3 6 5) (10.4 9 8))))) +(ert-deftest cl-macs-loop-and-arrays () + "Bug#40727" + (should (equal (cl-loop for y = (- (or x 0)) and x across [1 2] + collect (cons x y)) + '((1 . 0) (2 . -1)))) + (should (equal (cl-loop for x across [1 2] and y = (- (or x 0)) + collect (cons x y)) + '((1 . 0) (2 . -1))))) + (ert-deftest cl-macs-loop-destructure () (should (equal (cl-loop for (a b c) in '((1 2 4.0) (5 6 8.3) (8 9 10.4)) collect (list c b a)) @@ -416,7 +425,9 @@ collection clause." '(2 3 4 5 6)))) (ert-deftest cl-macs-loop-across-ref () - (should (equal (cl-loop with my-vec = ["one" "two" "three"] + (should (equal (cl-loop with my-vec = (vector (cl-copy-seq "one") + (cl-copy-seq "two") + (cl-copy-seq "three")) for x across-ref my-vec do (setf (aref x 0) (upcase (aref x 0))) finally return my-vec) @@ -498,7 +509,6 @@ collection clause." (ert-deftest cl-macs-loop-for-as-equals-and () "Test for https://debbugs.gnu.org/29799 ." - :expected-result :failed (let ((arr (make-vector 3 0))) (should (equal '((0 0) (1 1) (2 2)) (cl-loop for k below 3 for x = k and z = (elt arr k) @@ -532,7 +542,6 @@ collection clause." (ert-deftest cl-macs-loop-conditional-step-clauses () "These tests failed under the initial fixes in #bug#29799." - :expected-result :failed (should (cl-loop for i from 1 upto 100 and j = 1 then (1+ j) if (not (= i j)) return nil @@ -592,4 +601,13 @@ collection clause." collect y into result1 finally return (equal (nreverse result) result1)))) +(ert-deftest cl-macs-aux-edebug () + "Check that Bug#40431 is fixed." + (with-temp-buffer + (prin1 '(cl-defun cl-macs-aux-edebug-test-fun (&aux ((a . b) '(1 . 2))) + (list a b)) + (current-buffer)) + ;; Just make sure the function can be instrumented. + (edebug-defun))) + ;;; cl-macs-tests.el ends here diff --git a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el index 60e49ab93a4..7be057db8b2 100644 --- a/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el +++ b/test/lisp/emacs-lisp/edebug-resources/edebug-test-code.el @@ -1,4 +1,4 @@ -;;; edebug-test-code.el --- Sample code for the Edebug test suite +;;; edebug-test-code.el --- Sample code for the Edebug test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el index b3e296db16b..73c3ea82e2d 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-methodinvoke.el @@ -1,4 +1,4 @@ -;;; eieio-testsinvoke.el -- eieio tests for method invocation +;;; eieio-testsinvoke.el -- eieio tests for method invocation -*- lexical-binding:t -*- ;; Copyright (C) 2005, 2008, 2010, 2013-2020 Free Software Foundation, ;; Inc. @@ -83,36 +83,36 @@ (defclass eitest-B-base2 () ()) (defclass eitest-B (eitest-B-base1 eitest-B-base2) ()) -(defmethod eitest-F :BEFORE ((p eitest-B-base1)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base1)) (eieio-test-method-store :BEFORE 'eitest-B-base1)) -(defmethod eitest-F :BEFORE ((p eitest-B-base2)) +(defmethod eitest-F :BEFORE ((_p eitest-B-base2)) (eieio-test-method-store :BEFORE 'eitest-B-base2)) -(defmethod eitest-F :BEFORE ((p eitest-B)) +(defmethod eitest-F :BEFORE ((_p eitest-B)) (eieio-test-method-store :BEFORE 'eitest-B)) -(defmethod eitest-F ((p eitest-B)) +(defmethod eitest-F ((_p eitest-B)) (eieio-test-method-store :PRIMARY 'eitest-B) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base1)) +(defmethod eitest-F ((_p eitest-B-base1)) (eieio-test-method-store :PRIMARY 'eitest-B-base1) (call-next-method)) -(defmethod eitest-F ((p eitest-B-base2)) +(defmethod eitest-F ((_p eitest-B-base2)) (eieio-test-method-store :PRIMARY 'eitest-B-base2) (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F :AFTER ((p eitest-B-base1)) +(defmethod eitest-F :AFTER ((_p eitest-B-base1)) (eieio-test-method-store :AFTER 'eitest-B-base1)) -(defmethod eitest-F :AFTER ((p eitest-B-base2)) +(defmethod eitest-F :AFTER ((_p eitest-B-base2)) (eieio-test-method-store :AFTER 'eitest-B-base2)) -(defmethod eitest-F :AFTER ((p eitest-B)) +(defmethod eitest-F :AFTER ((_p eitest-B)) (eieio-test-method-store :AFTER 'eitest-B)) (ert-deftest eieio-test-method-order-list-3 () @@ -136,7 +136,7 @@ ;;; Test static invocation ;; -(defmethod eitest-H :STATIC ((class eitest-A)) +(defmethod eitest-H :STATIC ((_class eitest-A)) "No need to do work in here." 'moose) @@ -147,15 +147,15 @@ ;;; Return value from :PRIMARY ;; -(defmethod eitest-I :BEFORE ((a eitest-A)) +(defmethod eitest-I :BEFORE ((_a eitest-A)) (eieio-test-method-store :BEFORE 'eitest-A) ":before") -(defmethod eitest-I :PRIMARY ((a eitest-A)) +(defmethod eitest-I :PRIMARY ((_a eitest-A)) (eieio-test-method-store :PRIMARY 'eitest-A) ":primary") -(defmethod eitest-I :AFTER ((a eitest-A)) +(defmethod eitest-I :AFTER ((_a eitest-A)) (eieio-test-method-store :AFTER 'eitest-A) ":after") @@ -174,17 +174,17 @@ (defclass C (C-base1 C-base2) ()) ;; Just use the obsolete name once, to make sure it also works. -(defmethod constructor :STATIC ((p C-base1) &rest args) +(defmethod constructor :STATIC ((_p C-base1) &rest _args) (eieio-test-method-store :STATIC 'C-base1) (if (next-method-p) (call-next-method)) ) -(defmethod make-instance :STATIC ((p C-base2) &rest args) +(defmethod make-instance :STATIC ((_p C-base2) &rest _args) (eieio-test-method-store :STATIC 'C-base2) (if (next-method-p) (call-next-method)) ) -(cl-defmethod make-instance ((p (subclass C)) &rest args) +(cl-defmethod make-instance ((_p (subclass C)) &rest _args) (eieio-test-method-store :STATIC 'C) (cl-call-next-method) ) @@ -213,24 +213,24 @@ (defclass D-base2 (D-base0) () :method-invocation-order :depth-first) (defclass D (D-base1 D-base2) () :method-invocation-order :depth-first) -(defmethod eitest-F ((p D)) +(defmethod eitest-F ((_p D)) "D" (eieio-test-method-store :PRIMARY 'D) (call-next-method)) -(defmethod eitest-F ((p D-base0)) +(defmethod eitest-F ((_p D-base0)) "D-base0" (eieio-test-method-store :PRIMARY 'D-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p D-base1)) +(defmethod eitest-F ((_p D-base1)) "D-base1" (eieio-test-method-store :PRIMARY 'D-base1) (call-next-method)) -(defmethod eitest-F ((p D-base2)) +(defmethod eitest-F ((_p D-base2)) "D-base2" (eieio-test-method-store :PRIMARY 'D-base2) (when (next-method-p) @@ -256,21 +256,21 @@ (defclass E-base2 (E-base0) () :method-invocation-order :breadth-first) (defclass E (E-base1 E-base2) () :method-invocation-order :breadth-first) -(defmethod eitest-F ((p E)) +(defmethod eitest-F ((_p E)) (eieio-test-method-store :PRIMARY 'E) (call-next-method)) -(defmethod eitest-F ((p E-base0)) +(defmethod eitest-F ((_p E-base0)) (eieio-test-method-store :PRIMARY 'E-base0) ;; This should have no next ;; (when (next-method-p) (call-next-method)) ) -(defmethod eitest-F ((p E-base1)) +(defmethod eitest-F ((_p E-base1)) (eieio-test-method-store :PRIMARY 'E-base1) (call-next-method)) -(defmethod eitest-F ((p E-base2)) +(defmethod eitest-F ((_p E-base2)) (eieio-test-method-store :PRIMARY 'E-base2) (when (next-method-p) (call-next-method)) @@ -293,7 +293,7 @@ (defclass eitest-Ja () ()) -(defmethod initialize-instance :after ((this eitest-Ja) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Ja) &rest _slots) ;(message "+Ja") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -304,7 +304,7 @@ (defclass eitest-Jb () ()) -(defmethod initialize-instance :after ((this eitest-Jb) &rest slots) +(defmethod initialize-instance :after ((_this eitest-Jb) &rest _slots) ;(message "+Jb") ;; FIXME: Using next-method-p in an after-method is invalid! (when (next-method-p) @@ -318,7 +318,7 @@ (defclass eitest-Jd (eitest-Jc eitest-Ja) ()) -(defmethod initialize-instance ((this eitest-Jd) &rest slots) +(defmethod initialize-instance ((_this eitest-Jd) &rest _slots) ;(message "+Jd") (when (next-method-p) (call-next-method)) @@ -357,7 +357,7 @@ (call-next-method this (cons 'CNM-1-1 args)))) -(defmethod CNM-M ((this CNM-1-2) args) +(defmethod CNM-M ((_this CNM-1-2) args) (push (cons 'CNM-1-2 (copy-sequence args)) eieio-test-call-next-method-arguments) (when (next-method-p) diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el index 3c5aeaf708f..6979da8482b 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-test-persist.el @@ -1,4 +1,4 @@ -;;; eieio-test-persist.el --- Tests for eieio-persistent class +;;; eieio-test-persist.el --- Tests for eieio-persistent class -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el index 34c20b2003f..21adc91e555 100644 --- a/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el +++ b/test/lisp/emacs-lisp/eieio-tests/eieio-tests.el @@ -1,4 +1,4 @@ -;;; eieio-tests.el -- eieio tests routines +;;; eieio-tests.el -- eieio test routines -*- lexical-binding: t -*- ;; Copyright (C) 1999-2003, 2005-2010, 2012-2020 Free Software ;; Foundation, Inc. @@ -356,7 +356,7 @@ METHOD is the method that was attempting to be called." (oset a test-tag 1)) (let ((ca (class-a))) - (should-not (/= (oref ca test-tag) 2)))) + (should (= (oref ca test-tag) 2)))) ;;; Perform slot testing @@ -852,6 +852,7 @@ Subclasses to override slot attributes.") "Instance Tracker test object.") (ert-deftest eieio-test-33-instance-tracker () + (defvar IT-list) (let (IT-list IT1) (should (setq IT1 (IT))) ;; The instance tracker must find this diff --git a/test/lisp/emacs-lisp/ert-x-tests.el b/test/lisp/emacs-lisp/ert-x-tests.el index e910329c201..b760f8c7869 100644 --- a/test/lisp/emacs-lisp/ert-x-tests.el +++ b/test/lisp/emacs-lisp/ert-x-tests.el @@ -1,4 +1,4 @@ -;;; ert-x-tests.el --- Tests for ert-x.el +;;; ert-x-tests.el --- Tests for ert-x.el -*- lexical-binding:t -*- ;; Copyright (C) 2008, 2010-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el index 3017b52ab54..4bad36080a1 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-mode.el @@ -1,4 +1,4 @@ -;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. +;;; faceup-test-mode.el --- Dummy major mode for testing `faceup'. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el index ab638ef932f..d8ab02b650e 100644 --- a/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el +++ b/test/lisp/emacs-lisp/faceup-resources/faceup-test-this-file-directory.el @@ -1,4 +1,4 @@ -;;; faceup-test-this-file-directory.el --- Support file for faceup tests +;;; faceup-test-this-file-directory.el --- Support file for faceup tests -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el index 0838981fcb9..3c9ec76cdf7 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-basics.el @@ -1,4 +1,4 @@ -;;; faceup-test-basics.el --- Tests for the `faceup' package. +;;; faceup-test-basics.el --- Tests for the `faceup' package. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el index 4f5fe180bb3..a87c16d66c0 100644 --- a/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el +++ b/test/lisp/emacs-lisp/faceup-tests/faceup-test-files.el @@ -1,4 +1,4 @@ -;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. +;;; faceup-test-files.el --- Self test of `faceup' using dummy major mode. -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/float-sup-tests.el b/test/lisp/emacs-lisp/float-sup-tests.el new file mode 100644 index 00000000000..9f9a3daa28b --- /dev/null +++ b/test/lisp/emacs-lisp/float-sup-tests.el @@ -0,0 +1,33 @@ +;;; float-sup-tests.el --- Tests for float-sup.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest float-sup-degrees-and-radians () + (should (equal (degrees-to-radians 180.0) float-pi)) + (should (equal (radians-to-degrees float-pi) 180.0)) + (should (equal (radians-to-degrees (degrees-to-radians 360.0)) 360.0)) + (should (equal (degrees-to-radians (radians-to-degrees float-pi)) float-pi))) + +(provide 'float-sup-tests) +;;; float-sup-tests.el ends here diff --git a/test/lisp/emacs-lisp/generator-tests.el b/test/lisp/emacs-lisp/generator-tests.el index 0d325f1485a..9b1a573ea6a 100644 --- a/test/lisp/emacs-lisp/generator-tests.el +++ b/test/lisp/emacs-lisp/generator-tests.el @@ -26,6 +26,8 @@ (require 'ert) (require 'cl-lib) +;;; Code: + (defun generator-list-subrs () (cl-loop for x being the symbols when (and (fboundp x) @@ -38,8 +40,7 @@ `cps-testcase' defines an ERT testcase called NAME that evaluates BODY twice: once using ordinary `eval' and once using lambda-generators. The test ensures that the two forms produce -identical output. -" +identical output." `(progn (ert-deftest ,name () (should @@ -302,3 +303,14 @@ identical output. (lambda (it) (- it)) (1+ it))))))) -2))) + +(ert-deftest generator-tests-edebug () + "Check that Bug#40434 is fixed." + (with-temp-buffer + (prin1 '(iter-defun generator-tests-edebug () + (iter-yield 123)) + (current-buffer)) + (edebug-defun)) + (should (eql (iter-next (generator-tests-edebug)) 123))) + +;;; generator-tests.el ends here diff --git a/test/lisp/emacs-lisp/gv-tests.el b/test/lisp/emacs-lisp/gv-tests.el index 7fa4cd50b08..7a8402be074 100644 --- a/test/lisp/emacs-lisp/gv-tests.el +++ b/test/lisp/emacs-lisp/gv-tests.el @@ -19,6 +19,7 @@ ;;; Code: +(require 'edebug) (require 'ert) (eval-when-compile (require 'cl-lib)) @@ -137,6 +138,24 @@ (should (equal (buffer-string) "Symbol's function definition is void: \\(setf\\ gv-test-foo\\)\n"))))) +(ert-deftest gv-setter-edebug () + "Check that a setter can be defined and edebugged together with +its getter (Bug#41853)." + (with-temp-buffer + (let ((edebug-all-defs t) + (edebug-initial-mode 'Go-nonstop)) + (dolist (form '((defun gv-setter-edebug-help (b) b) + (defun gv-setter-edebug-get (a b) + (get a (gv-setter-edebug-help b))) + (gv-define-setter gv-setter-edebug-get (x a b) + `(setf (get ,a (gv-setter-edebug-help ,b)) ,x)) + (push 123 (gv-setter-edebug-get 'gv-setter-edebug + 'gv-setter-edebug-prop)))) + (print form (current-buffer))) + ;; Only check whether evaluation works in general. + (eval-buffer))) + (should (equal (get 'gv-setter-edebug 'gv-setter-edebug-prop) '(123)))) + ;; `ert-deftest' messes up macroexpansion when the test file itself is ;; compiled (see Bug #24402). diff --git a/test/lisp/emacs-lisp/map-tests.el b/test/lisp/emacs-lisp/map-tests.el index c52bb83fa33..1888baf6017 100644 --- a/test/lisp/emacs-lisp/map-tests.el +++ b/test/lisp/emacs-lisp/map-tests.el @@ -376,5 +376,11 @@ Evaluate BODY for each created map. '((1 . 1) (2 . 5) (3 . 0))) '((3 . 0) (2 . 9) (1 . 6))))) +(ert-deftest test-map-plist-pcase () + (let ((plist '(:one 1 :two 2))) + (should (equal (pcase-let (((map :one (:two two)) plist)) + (list one two)) + '(1 2))))) + (provide 'map-tests) ;;; map-tests.el ends here diff --git a/test/lisp/emacs-lisp/nadvice-tests.el b/test/lisp/emacs-lisp/nadvice-tests.el index eabe3cb1970..a955df0a696 100644 --- a/test/lisp/emacs-lisp/nadvice-tests.el +++ b/test/lisp/emacs-lisp/nadvice-tests.el @@ -1,4 +1,4 @@ -;;; advice-tests.el --- Test suite for the new advice thingy. +;;; nadvice-tests.el --- Test suite for the new advice thingy. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el index 7251622fa59..61c1b045990 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/new-pkg-1.0.el @@ -1,4 +1,4 @@ -;;; new-pkg.el --- A package only seen after "updating" archive-contents +;;; new-pkg.el --- A package only seen after "updating" archive-contents -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el index 7b1c00c06db..301993deb30 100644 --- a/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el +++ b/test/lisp/emacs-lisp/package-resources/newer-versions/simple-single-1.4.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.4 diff --git a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el index b58b658d024..cb003905bb5 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el +++ b/test/lisp/emacs-lisp/package-resources/simple-depend-1.0.el @@ -1,4 +1,4 @@ -;;; simple-depend.el --- A single-file package with a dependency. +;;; simple-depend.el --- A single-file package with a dependency. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.0 diff --git a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el index 6756a28080b..9c3f427ff48 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el +++ b/test/lisp/emacs-lisp/package-resources/simple-single-1.3.el @@ -1,4 +1,4 @@ -;;; simple-single.el --- A single-file package with no dependencies +;;; simple-single.el --- A single-file package with no dependencies -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.3 diff --git a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el index 9cfe5c0d4e2..a0a9607350a 100644 --- a/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el +++ b/test/lisp/emacs-lisp/package-resources/simple-two-depend-1.1.el @@ -1,4 +1,4 @@ -;;; simple-two-depend.el --- A single-file package with two dependencies. +;;; simple-two-depend.el --- A single-file package with two dependencies. -*- lexical-binding:t -*- ;; Author: J. R. Hacker <jrh@example.com> ;; Version: 1.1 diff --git a/test/lisp/emacs-lisp/package-tests.el b/test/lisp/emacs-lisp/package-tests.el index 4fcaf0e84c2..cb06dd4cce3 100644 --- a/test/lisp/emacs-lisp/package-tests.el +++ b/test/lisp/emacs-lisp/package-tests.el @@ -1,4 +1,4 @@ -;;; package-test.el --- Tests for the Emacs package system +;;; package-test.el --- Tests for the Emacs package system -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -143,8 +143,8 @@ ,(if basedir `(cd ,basedir)) (unless (file-directory-p package-user-dir) (mkdir package-user-dir)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest r) t)) - ((symbol-function 'y-or-n-p) (lambda (&rest r) t))) + (cl-letf (((symbol-function 'yes-or-no-p) (lambda (&rest _) t)) + ((symbol-function 'y-or-n-p) (lambda (&rest _) t))) ,@(when install `((package-initialize) (package-refresh-contents) @@ -175,9 +175,8 @@ (defun package-test-suffix-matches (base suffix-list) "Return file names matching BASE concatenated with each item in SUFFIX-LIST" - (cl-mapcan - '(lambda (item) (file-expand-wildcards (concat base item))) - suffix-list)) + (mapcan (lambda (item) (file-expand-wildcards (concat base item))) + suffix-list)) (defvar tar-parse-info) (declare-function tar-header-name "tar-mode" (cl-x) t) ; defstruct @@ -352,48 +351,122 @@ Must called from within a `tar-mode' buffer." (goto-char (point-min)) (should (re-search-forward re nil t))))))) + +;;; Package Menu tests + +(defmacro with-package-menu-test (&rest body) + "Set up Package Menu (\"*Packages*\") buffer for testing." + (declare (indent 0) (debug (([&rest form]) body))) + `(with-package-test () + (let ((buf (package-list-packages))) + (unwind-protect + (progn ,@body) + (kill-buffer buf))))) + (ert-deftest package-test-update-listing () "Ensure installed package status is updated." - (with-package-test () - (let ((buf (package-list-packages))) - (search-forward-regexp "^ +simple-single") - (package-menu-mark-install) - (package-menu-execute) - (run-hooks 'post-command-hook) - (should (package-installed-p 'simple-single)) - (switch-to-buffer "*Packages*") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) - (goto-char (point-min)) - (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)) - (kill-buffer buf)))) + (with-package-menu-test + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-execute) + (run-hooks 'post-command-hook) + (should (package-installed-p 'simple-single)) + (switch-to-buffer "*Packages*") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+installed" nil t)) + (goto-char (point-min)) + (should-not (re-search-forward "^\\s-+simple-single\\s-+1.3\\s-+\\(available\\|new\\)" nil t)))) + +(ert-deftest package-test-list-filter-by-archive () + "Ensure package list is filtered correctly by archive version." + (with-package-menu-test + ;; TODO: Add another package archive to test filtering, because + ;; the testing environment currently only has one. + (package-menu-filter-by-archive "gnu") + (goto-char (point-min)) + (should (looking-at "^\\s-+multi-file")) + (should (= (count-lines (point-min) (point-max)) 4)) + (should-error (package-menu-filter-by-archive "non-existent archive")))) + +(ert-deftest package-test-list-filter-by-keyword () + "Ensure package list is filtered correctly by package keyword." + (with-package-menu-test + (package-menu-filter-by-keyword "frobnicate") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (should-error (package-menu-filter-by-keyword "non-existent-keyword")))) (ert-deftest package-test-list-filter-by-name () "Ensure package list is filtered correctly by package name." + (with-package-menu-test () + (package-menu-filter-by-name "tetris") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+tetris" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)))) + +(ert-deftest package-test-list-filter-by-status () + "Ensure package list is filtered correctly by package status." + (with-package-menu-test + (package-menu-filter-by-status "available") + (goto-char (point-min)) + (should (re-search-forward "^\\s-+multi-file" nil t)) + (should (= (count-lines (point-min) (point-max)) 4)) + ;; No installed packages in default environment. + (should-error (package-menu-filter-by-status "installed")))) + +(ert-deftest package-test-list-filter-marked () + "Ensure package list is filtered correctly by non-empty mark." (with-package-test () - (let ((buf (package-list-packages))) - (package-menu-filter-by-name "tetris") - (goto-char (point-min)) - (should (re-search-forward "^\\s-+tetris" nil t)) - (should (= (count-lines (point-min) (point-max)) 1)) - (kill-buffer buf)))) + (package-list-packages) + (revert-buffer) + (search-forward-regexp "^ +simple-single") + (package-menu-mark-install) + (package-menu-filter-marked) + (goto-char (point-min)) + (should (re-search-forward "^I +simple-single" nil t)) + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-mark-unmark) + ;; No marked packages in default environment. + (should-error (package-menu-filter-marked)))) + +(ert-deftest package-test-list-filter-by-version () + (with-package-menu-test + (should-error (package-menu-filter-by-version "1.1" 'unknown-symbol))) ) + +(defun package-test-filter-by-version (version predicate name) + (with-package-menu-test + (package-menu-filter-by-version version predicate) + (goto-char (point-min)) + ;; We just check that the given package is included in the + ;; listing. One could be more ambitious. + (should (re-search-forward name)))) + +(ert-deftest package-test-list-filter-by-version-= () + "Ensure package list is filtered correctly by package version (=)." + (package-test-filter-by-version "1.1" '= "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-< () + "Ensure package list is filtered correctly by package version (<)." + (package-test-filter-by-version "1.2" '< "^\\s-+simple-two-depend")) + +(ert-deftest package-test-list-filter-by-version-> () + "Ensure package list is filtered correctly by package version (>)." + (package-test-filter-by-version "1.0" '> "^\\s-+simple-two-depend")) (ert-deftest package-test-list-clear-filter () "Ensure package list filter is cleared correctly." - (with-package-test () - (let ((buf (package-list-packages))) - (let ((num-packages (count-lines (point-min) (point-max)))) - (should (> num-packages 1)) - (package-menu-filter-by-name "tetris") - (should (= (count-lines (point-min) (point-max)) 1)) - (package-menu-clear-filter) - (should (= (count-lines (point-min) (point-max)) num-packages))) - (kill-buffer buf)))) + (with-package-menu-test + (let ((num-packages (count-lines (point-min) (point-max)))) + (package-menu-filter-by-name "tetris") + (should (= (count-lines (point-min) (point-max)) 1)) + (package-menu-clear-filter) + (should (= (count-lines (point-min) (point-max)) num-packages))))) (ert-deftest package-test-update-archives () "Test updating package archives." (with-package-test () - (let ((buf (package-list-packages))) + (let ((_buf (package-list-packages))) (revert-buffer) (search-forward-regexp "^ +simple-single") (package-menu-mark-install) @@ -537,6 +610,7 @@ Must called from within a `tar-mode' buffer." (should (search-forward "This is a bare-bones readme file for the multi-file" nil t))))) +(defvar epg-config--program-alist) ; Silence byte-compiler. (ert-deftest package-test-signed () "Test verifying package signature." (skip-unless (let ((homedir (make-temp-file "package-test" t))) @@ -577,8 +651,8 @@ Must called from within a `tar-mode' buffer." (should (progn (package-install 'signed-good) 'noerror)) (should (progn (package-install 'signed-bad) 'noerror))) ;; Check if the installed package status is updated. - (let ((buf (package-list-packages))) - (revert-buffer) + (let ((_buf (package-list-packages))) + (revert-buffer) (should (re-search-forward "^\\s-+signed-good\\s-+\\(\\S-+\\)\\s-+\\(\\S-+\\)\\s-" nil t)) diff --git a/test/lisp/emacs-lisp/pcase-tests.el b/test/lisp/emacs-lisp/pcase-tests.el index 0b69bd99f32..ac512416b71 100644 --- a/test/lisp/emacs-lisp/pcase-tests.el +++ b/test/lisp/emacs-lisp/pcase-tests.el @@ -1,4 +1,4 @@ -;;; pcase-tests.el --- Test suite for pcase macro. +;;; pcase-tests.el --- Test suite for pcase macro. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/regexp-opt-tests.el b/test/lisp/emacs-lisp/regexp-opt-tests.el index 0179ac4f1f4..ff93b8b759e 100644 --- a/test/lisp/emacs-lisp/regexp-opt-tests.el +++ b/test/lisp/emacs-lisp/regexp-opt-tests.el @@ -25,27 +25,14 @@ (require 'regexp-opt) -(defun regexp-opt-test--permutation (n list) - "The Nth permutation of LIST, 0 ≤ N < (length LIST)!." - (let ((len (length list)) - (perm-list nil)) - (dotimes (i len) - (let* ((d (- len i)) - (k (mod n d))) - (push (nth k list) perm-list) - (setq list (append (butlast list (- (length list) k)) - (nthcdr (1+ k) list))) - (setq n (/ n d)))) - (nreverse perm-list))) - -(defun regexp-opt-test--factorial (n) - "N!" - (apply #'* (number-sequence 1 n))) - -(defun regexp-opt-test--permutations (list) - "All permutations of LIST." - (mapcar (lambda (i) (regexp-opt-test--permutation i list)) - (number-sequence 0 (1- (regexp-opt-test--factorial (length list)))))) +(defun regexp-opt-test--permutations (l) + "All permutations of L, assuming no duplicates." + (if (cdr l) + (mapcan (lambda (x) + (mapcar (lambda (p) (cons x p)) + (regexp-opt-test--permutations (remove x l)))) + l) + (list l))) (ert-deftest regexp-opt-longest-match () "Check that the regexp always matches as much as possible." diff --git a/test/lisp/emacs-lisp/rx-tests.el b/test/lisp/emacs-lisp/rx-tests.el index 0fece4004bd..0e6f27836ea 100644 --- a/test/lisp/emacs-lisp/rx-tests.el +++ b/test/lisp/emacs-lisp/rx-tests.el @@ -63,6 +63,7 @@ (ert-deftest rx-char-any () "Test character alternatives with `]' and `-' (Bug#25123)." (should (equal + ;; relint suppression: Range .<-]. overlaps previous .]-{ (rx string-start (1+ (char (?\] . ?\{) (?< . ?\]) (?- . ?:))) string-end) "\\`[.-:<-{-]+\\'"))) @@ -127,6 +128,10 @@ "[[:lower:][:upper:]-][^[:lower:][:upper:]-]")) (should (equal (rx (any "]" lower upper) (not (any "]" lower upper))) "[][:lower:][:upper:]][^][:lower:][:upper:]]")) + ;; relint suppression: Duplicated character .-. + ;; relint suppression: Single-character range .f-f + ;; relint suppression: Range .--/. overlaps previous .- + ;; relint suppression: Range .\*--. overlaps previous .--/ (should (equal (rx (any "-a" "c-" "f-f" "--/*--")) "[*-/acf]")) (should (equal (rx (any "]-a" ?-) (not (any "]-a" ?-))) @@ -140,6 +145,7 @@ "\\`a\\`[^z-a]")) (should (equal (rx (any "") (not (any ""))) "\\`a\\`[^z-a]")) + ;; relint suppression: Duplicated class .space. (should (equal (rx (any space ?a digit space)) "[a[:space:][:digit:]]")) (should (equal (rx (not "\n") (not ?\n) (not (any "\n")) (not-char ?\n) diff --git a/test/lisp/emacs-lisp/seq-tests.el b/test/lisp/emacs-lisp/seq-tests.el index 77ee4f5c38d..a6a80952360 100644 --- a/test/lisp/emacs-lisp/seq-tests.el +++ b/test/lisp/emacs-lisp/seq-tests.el @@ -1,4 +1,4 @@ -;;; seq-tests.el --- Tests for sequences.el +;;; seq-tests.el --- Tests for seq.el -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -126,7 +126,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-filter #'test-sequences-evenp seq) '(6 8 10))) (should (equal (seq-filter #'test-sequences-oddp seq) '(7 9))) - (should (equal (seq-filter (lambda (elt) nil) seq) '()))) + (should (equal (seq-filter (lambda (_) nil) seq) '()))) (with-test-sequences (seq '()) (should (equal (seq-filter #'test-sequences-evenp seq) '())))) @@ -134,7 +134,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-remove #'test-sequences-evenp seq) '(7 9))) (should (equal (seq-remove #'test-sequences-oddp seq) '(6 8 10))) - (should (same-contents-p (seq-remove (lambda (elt) nil) seq) seq))) + (should (same-contents-p (seq-remove (lambda (_) nil) seq) seq))) (with-test-sequences (seq '()) (should (equal (seq-remove #'test-sequences-evenp seq) '())))) @@ -142,7 +142,7 @@ Evaluate BODY for each created sequence. (with-test-sequences (seq '(6 7 8 9 10)) (should (equal (seq-count #'test-sequences-evenp seq) 3)) (should (equal (seq-count #'test-sequences-oddp seq) 2)) - (should (equal (seq-count (lambda (elt) nil) seq) 0))) + (should (equal (seq-count (lambda (_) nil) seq) 0))) (with-test-sequences (seq '()) (should (equal (seq-count #'test-sequences-evenp seq) 0)))) @@ -199,7 +199,7 @@ Evaluate BODY for each created sequence. (ert-deftest test-seq-every-p () (with-test-sequences (seq '(43 54 22 1)) - (should (seq-every-p (lambda (elt) t) seq)) + (should (seq-every-p (lambda (_) t) seq)) (should-not (seq-every-p #'test-sequences-oddp seq)) (should-not (seq-every-p #'test-sequences-evenp seq))) (with-test-sequences (seq '(42 54 22 2)) diff --git a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p1/foo.el +++ b/test/lisp/emacs-lisp/shadow-resources/p1/foo.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el index 465038bee5e..ffe68f9356f 100644 --- a/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el +++ b/test/lisp/emacs-lisp/shadow-resources/p2/FOO.el @@ -1 +1 @@ -;;; This file intentionally left blank. +;;; This file intentionally left blank. -*- lexical-binding:t -*- diff --git a/test/lisp/emacs-lisp/subr-x-tests.el b/test/lisp/emacs-lisp/subr-x-tests.el index 220ce0c08f0..c702fdff6f1 100644 --- a/test/lisp/emacs-lisp/subr-x-tests.el +++ b/test/lisp/emacs-lisp/subr-x-tests.el @@ -1,4 +1,4 @@ -;;; subr-x-tests.el --- Testing the extended lisp routines +;;; subr-x-tests.el --- Testing the extended lisp routines -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emacs-lisp/syntax-tests.el b/test/lisp/emacs-lisp/syntax-tests.el new file mode 100644 index 00000000000..9d4c4113fdd --- /dev/null +++ b/test/lisp/emacs-lisp/syntax-tests.el @@ -0,0 +1,67 @@ +;;; syntax-tests.el --- tests for syntax.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software; you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Code: + +(require 'ert) +(require 'syntax) + +(ert-deftest syntax-propertize--shift-groups-and-backrefs () + "Test shifting of numbered groups and back-references in regexps." + ;; A numbered group must be shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foobar" 2) + "\\(?4:[abc]+\\)foobar")) + ;; A back-reference \1 on a normal sub-regexp context must be + ;; shifted. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\1" 2) + "\\(a\\)\\3")) + ;; Shifting must not happen if the \1 appears in a character class, + ;; or in a \{\} repetition construct (although \1 isn't valid there + ;; anyway). + (let ((rx-with-class "\\(a\\)[\\1-2]") + (rx-with-rep "\\(a\\)\\{1,\\1\\}")) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-class 2) + rx-with-class)) + (should + (string= + (syntax-propertize--shift-groups-and-backrefs rx-with-rep 2) + rx-with-rep))) + ;; Now numbered groups and back-references in combination. + (should + (string= + (syntax-propertize--shift-groups-and-backrefs + "\\(?2:[abc]+\\)foo\\(\\2\\)" 2) + "\\(?4:[abc]+\\)foo\\(\\4\\)")) + ;; Emacs supports only the back-references \1,...,\9, so when a + ;; shift would result in \10 or more, an error must be signalled. + (should-error + (syntax-propertize--shift-groups-and-backrefs "\\(a\\)\\3" 7))) + +;; Local Variables: +;; no-byte-compile: t +;; End: + +;;; syntax-tests.el ends here. diff --git a/test/lisp/emacs-lisp/text-property-search-tests.el b/test/lisp/emacs-lisp/text-property-search-tests.el index 26b89b72312..549c90d20d8 100644 --- a/test/lisp/emacs-lisp/text-property-search-tests.el +++ b/test/lisp/emacs-lisp/text-property-search-tests.el @@ -1,4 +1,4 @@ -;;; text-property-search-tests.el --- Testing text-property-search +;;; text-property-search-tests.el --- Testing text-property-search -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/emulation/viper-tests.el b/test/lisp/emulation/viper-tests.el index 33f85e51254..b981938fe19 100644 --- a/test/lisp/emulation/viper-tests.el +++ b/test/lisp/emulation/viper-tests.el @@ -1,4 +1,4 @@ -;;; viper-tests.el --- tests for viper. +;;; viper-tests.el --- tests for viper. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/erc/erc-track-tests.el b/test/lisp/erc/erc-track-tests.el index b0ed4bbcb67..457f08cb73c 100644 --- a/test/lisp/erc/erc-track-tests.el +++ b/test/lisp/erc/erc-track-tests.el @@ -1,4 +1,4 @@ -;;; erc-track-tests.el --- Tests for erc-track. +;;; erc-track-tests.el --- Tests for erc-track. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. @@ -107,8 +107,8 @@ (ert-deftest erc-track--erc-faces-in () "`erc-faces-in' should pick up both 'face and 'font-lock-face properties." - (let ((str0 "is bold") - (str1 "is bold")) + (let ((str0 (copy-sequence "is bold")) + (str1 (copy-sequence "is bold"))) ;; Turn on Font Lock mode: this initialize `char-property-alias-alist' ;; to '((face font-lock-face)). Note that `font-lock-mode' don't ;; turn on the mode if the test is run on batch mode or if the diff --git a/test/lisp/eshell/em-hist-tests.el b/test/lisp/eshell/em-hist-tests.el index a08a7a2afcb..5bb16f64a46 100644 --- a/test/lisp/eshell/em-hist-tests.el +++ b/test/lisp/eshell/em-hist-tests.el @@ -1,4 +1,4 @@ -;;; tests/em-hist-tests.el --- em-hist test suite +;;; tests/em-hist-tests.el --- em-hist test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/em-ls-tests.el b/test/lisp/eshell/em-ls-tests.el index da3e224a94d..975701e3838 100644 --- a/test/lisp/eshell/em-ls-tests.el +++ b/test/lisp/eshell/em-ls-tests.el @@ -1,4 +1,4 @@ -;;; tests/em-ls-tests.el --- em-ls test suite +;;; tests/em-ls-tests.el --- em-ls test suite -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/esh-opt-tests.el b/test/lisp/eshell/esh-opt-tests.el index af6c089c16b..caba153cf73 100644 --- a/test/lisp/eshell/esh-opt-tests.el +++ b/test/lisp/eshell/esh-opt-tests.el @@ -1,4 +1,4 @@ -;;; tests/esh-opt-tests.el --- esh-opt test suite +;;; tests/esh-opt-tests.el --- esh-opt test suite -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/eshell/eshell-tests.el b/test/lisp/eshell/eshell-tests.el index 70694309443..16a04647723 100644 --- a/test/lisp/eshell/eshell-tests.el +++ b/test/lisp/eshell/eshell-tests.el @@ -170,6 +170,13 @@ e.g. \"{(+ 1 2)} 3\" => 3" (eshell-command-result-p "+ 1 2; + $_ 4" "3\n6\n"))) +(ert-deftest eshell-test/inside-emacs-var () + "Test presence of \"INSIDE_EMACS\" in subprocesses" + (with-temp-eshell + (eshell-command-result-p "env" + (format "INSIDE_EMACS=%s,eshell" + emacs-version)))) + (ert-deftest eshell-test/escape-nonspecial () "Test that \"\\c\" and \"c\" are equivalent when \"c\" is not a special character." diff --git a/test/lisp/ffap-tests.el b/test/lisp/ffap-tests.el index eaf39680e48..30c8f794577 100644 --- a/test/lisp/ffap-tests.el +++ b/test/lisp/ffap-tests.el @@ -74,7 +74,7 @@ left alone when opening a URL in an external browser." (urls nil) (ffap-url-fetcher (lambda (url) (push url urls) nil))) (should-not (ffap-other-window "https://www.gnu.org")) - (should (equal (current-window-configuration) old)) + (should (compare-window-configurations (current-window-configuration) old)) (should (equal urls '("https://www.gnu.org"))))) (provide 'ffap-tests) diff --git a/test/lisp/filenotify-tests.el b/test/lisp/filenotify-tests.el index e9dc7532d59..42d86ee1538 100644 --- a/test/lisp/filenotify-tests.el +++ b/test/lisp/filenotify-tests.el @@ -200,8 +200,7 @@ Return nil when any other file notification watch is still active." (setq file-notify-debug nil password-cache-expiry nil - tramp-verbose 0 - tramp-message-show-message nil) + tramp-verbose 0) ;; This should happen on hydra only. (when (getenv "EMACS_HYDRA_CI") @@ -220,7 +219,8 @@ remote case we return always t." (or file-notify--library (file-remote-p temporary-file-directory))) -(defvar file-notify--test-remote-enabled-checked nil +(defvar file-notify--test-remote-enabled-checked + (if (getenv "EMACS_HYDRA_CI") '(t . nil)) "Cached result of `file-notify--test-remote-enabled'. If the function did run, the value is a cons cell, the `cdr' being the result.") @@ -772,9 +772,9 @@ delivered." (copy-file file-notify--test-tmpfile file-notify--test-tmpfile1) ;; The next two events shall not be visible. (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) + (set-file-modes file-notify--test-tmpfile 000 'nofollow) (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) + (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) (file-notify--test-read-event) (delete-directory file-notify--test-tmpdir 'recursive)) (file-notify-rm-watch file-notify--test-desc) @@ -865,9 +865,9 @@ delivered." (write-region "any text" nil file-notify--test-tmpfile nil 'no-message) (file-notify--test-read-event) - (set-file-modes file-notify--test-tmpfile 000) + (set-file-modes file-notify--test-tmpfile 000 'nofollow) (file-notify--test-read-event) - (set-file-times file-notify--test-tmpfile '(0 0)) + (set-file-times file-notify--test-tmpfile '(0 0) 'nofollow) (file-notify--test-read-event) (delete-file file-notify--test-tmpfile)) (file-notify-rm-watch file-notify--test-desc) @@ -929,17 +929,18 @@ delivered." ;; Modify file. We wait for a second, in order to have ;; another timestamp. (ert-with-message-capture captured-messages - (sleep-for 1) - (write-region - "another text" nil file-notify--test-tmpfile nil 'no-message) - - ;; Check, that the buffer has been reverted. - (file-notify--test-wait-for-events - timeout - (string-match - (format-message "Reverting buffer `%s'." (buffer-name buf)) - captured-messages)) - (should (string-match "another text" (buffer-string)))) + (let ((inhibit-message t)) + (sleep-for 1) + (write-region + "another text" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (file-notify--test-wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + captured-messages)) + (should (string-match "another text" (buffer-string))))) ;; Stop file notification. Autorevert shall still work via polling. (file-notify-rm-watch auto-revert-notify-watch-descriptor) @@ -953,17 +954,18 @@ delivered." ;; have another timestamp. One second seems to be too ;; short. And Cygwin sporadically requires more than two. (ert-with-message-capture captured-messages - (sleep-for (if (eq system-type 'cygwin) 3 2)) - (write-region - "foo bla" nil file-notify--test-tmpfile nil 'no-message) - - ;; Check, that the buffer has been reverted. - (file-notify--test-wait-for-events - timeout - (string-match - (format-message "Reverting buffer `%s'." (buffer-name buf)) - captured-messages)) - (should (string-match "foo bla" (buffer-string)))) + (let ((inhibit-message t)) + (sleep-for (if (eq system-type 'cygwin) 3 2)) + (write-region + "foo bla" nil file-notify--test-tmpfile nil 'no-message) + + ;; Check, that the buffer has been reverted. + (file-notify--test-wait-for-events + timeout + (string-match + (format-message "Reverting buffer `%s'." (buffer-name buf)) + captured-messages)) + (should (string-match "foo bla" (buffer-string))))) ;; Stop autorevert, in order to cleanup descriptor. (auto-revert-mode -1)) diff --git a/test/lisp/files-tests.el b/test/lisp/files-tests.el index ac56a7732f2..4b902fd82ae 100644 --- a/test/lisp/files-tests.el +++ b/test/lisp/files-tests.el @@ -1003,9 +1003,9 @@ unquoted file names." (ert-deftest files-tests-file-name-non-special-set-file-times () (files-tests--with-temp-non-special (tmpfile nospecial) - (set-file-times nospecial)) + (set-file-times nospecial nil 'nofollow)) (files-tests--with-temp-non-special-and-file-name-handler (tmpfile nospecial) - (should-error (set-file-times nospecial)))) + (should-error (set-file-times nospecial nil 'nofollow)))) (ert-deftest files-tests-file-name-non-special-set-visited-file-modtime () (files-tests--with-temp-non-special (tmpfile nospecial) @@ -1164,6 +1164,42 @@ works as expected if the default directory is quoted." (should-not (make-directory a/b t)) (delete-directory dir 'recursive))) +(ert-deftest files-tests-file-modes-symbolic-to-number () + (let ((alist (list (cons "a=rwx" #o777) + (cons "o=t" #o1000) + (cons "o=xt" #o1001) + (cons "o=tx" #o1001) ; Order doesn't matter. + (cons "u=rwx,g=rx,o=rx" #o755) + (cons "u=rwx,g=,o=" #o700) + (cons "u=rwx" #o700) ; Empty permissions can be ignored. + (cons "u=rw,g=r,o=r" #o644) + (cons "u=rw,g=r,o=t" #o1640) + (cons "u=rw,g=r,o=xt" #o1641) + (cons "u=rwxs,g=rs,o=xt" #o7741) + (cons "u=rws,g=rs,o=t" #o7640) + (cons "u=rws,g=rs,o=r" #o6644) + (cons "a=r" #o444) + (cons "u=S" nil) + (cons "u=T" nil) + (cons "u=Z" nil)))) + (dolist (x alist) + (if (cdr-safe x) + (should (equal (cdr x) (file-modes-symbolic-to-number (car x)))) + (should-error (file-modes-symbolic-to-number (car x))))))) + +(ert-deftest files-tests-file-modes-number-to-symbolic () + (let ((alist (list (cons #o755 "-rwxr-xr-x") + (cons #o700 "-rwx------") + (cons #o644 "-rw-r--r--") + (cons #o1640 "-rw-r----T") + (cons #o1641 "-rw-r----t") + (cons #o7741 "-rwsr-S--t") + (cons #o7640 "-rwSr-S--T") + (cons #o6644 "-rwSr-Sr--") + (cons #o444 "-r--r--r--")))) + (dolist (x alist) + (should (equal (cdr x) (file-modes-number-to-symbolic (car x))))))) + (ert-deftest files-tests-no-file-write-contents () "Test that `write-contents-functions' permits saving a file. Usually `basic-save-buffer' will prompt for a file name if the diff --git a/test/lisp/format-spec-tests.el b/test/lisp/format-spec-tests.el index 23ee88c5269..11882217afb 100644 --- a/test/lisp/format-spec-tests.el +++ b/test/lisp/format-spec-tests.el @@ -22,22 +22,145 @@ (require 'ert) (require 'format-spec) -(ert-deftest test-format-spec () +(ert-deftest format-spec-make () + "Test `format-spec-make'." + (should-not (format-spec-make)) + (should-error (format-spec-make ?b)) + (should (equal (format-spec-make ?b "b") '((?b . "b")))) + (should-error (format-spec-make ?b "b" ?a)) + (should (equal (format-spec-make ?b "b" ?a 'a) + '((?b . "b") + (?a . a))))) + +(ert-deftest format-spec-parse-flags () + "Test `format-spec--parse-flags'." + (should-not (format-spec--parse-flags nil)) + (should-not (format-spec--parse-flags "")) + (should (equal (format-spec--parse-flags "-") '(:pad-right))) + (should (equal (format-spec--parse-flags " 0") '(:pad-zero))) + (should (equal (format-spec--parse-flags " -x0y< >^_z ") + '(:pad-right :pad-zero :chop-left :chop-right + :upcase :downcase)))) + +(ert-deftest format-spec-do-flags () + "Test `format-spec--do-flags'." + (should (equal (format-spec--do-flags "" () nil nil) "")) + (dolist (flag '(:pad-zero :pad-right :upcase :downcase + :chop-left :chop-right)) + (should (equal (format-spec--do-flags "" (list flag) nil nil) ""))) + (should (equal (format-spec--do-flags "FOOBAR" '(:downcase :chop-right) 5 2) + " fo")) + (should (equal (format-spec--do-flags + "foobar" '(:pad-zero :pad-right :upcase :chop-left) 5 2) + "AR000"))) + +(ert-deftest format-spec-do-flags-truncate () + "Test `format-spec--do-flags' truncation." + (let (flags) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "a"))) + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "" flags nil 0) "")) + (should (equal (format-spec--do-flags "" flags nil 1) "")) + (should (equal (format-spec--do-flags "a" flags nil 0) "")) + (should (equal (format-spec--do-flags "a" flags nil 1) "a")) + (should (equal (format-spec--do-flags "a" flags nil 2) "a")) + (should (equal (format-spec--do-flags "asd" flags nil 0) "")) + (should (equal (format-spec--do-flags "asd" flags nil 1) "d")))) + +(ert-deftest format-spec-do-flags-pad () + "Test `format-spec--do-flags' padding." + (let (flags) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) " a"))) + (let ((flags '(:pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "0a"))) + (let ((flags '(:pad-right))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) " ")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a "))) + (let ((flags '(:pad-right :pad-zero))) + (should (equal (format-spec--do-flags "" flags 0 nil) "")) + (should (equal (format-spec--do-flags "" flags 1 nil) "0")) + (should (equal (format-spec--do-flags "a" flags 0 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "a" flags 2 nil) "a0")))) + +(ert-deftest format-spec-do-flags-chop () + "Test `format-spec--do-flags' chopping." + (let ((flags '(:chop-left))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "d"))) + (let ((flags '(:chop-right))) + (should (equal (format-spec--do-flags "a" flags 0 nil) "")) + (should (equal (format-spec--do-flags "a" flags 1 nil) "a")) + (should (equal (format-spec--do-flags "asd" flags 0 nil) "")) + (should (equal (format-spec--do-flags "asd" flags 1 nil) "a")))) + +(ert-deftest format-spec-do-flags-case () + "Test `format-spec--do-flags' case fiddling." + (dolist (flag '(:pad-zero :pad-right :chop-left :chop-right)) + (let ((flags (list flag))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))) + (let ((flags (list flag :downcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "a")) + (should (equal (format-spec--do-flags "A" flags nil nil) "a"))) + (let ((flags (list flag :upcase))) + (should (equal (format-spec--do-flags "a" flags nil nil) "A")) + (should (equal (format-spec--do-flags "A" flags nil nil) "A"))))) + +(ert-deftest format-spec () + (should (equal (format-spec "" ()) "")) + (should (equal (format-spec "a" ()) "a")) + (should (equal (format-spec "b" '((?b . "bar"))) "b")) + (should (equal (format-spec "%%%b%%b%b%%" '((?b . "bar"))) "%bar%bbar%")) (should (equal (format-spec "foo %b zot" `((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %-10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) - "foo bar zot"))) + "foo bar zot")) + (should (equal-including-properties + (format-spec (propertize "a" 'a 'b) '((?a . "foo"))) + #("a" 0 1 (a b)))) + (let ((fmt (concat (propertize "%a" 'a 'b) + (propertize "%%" 'c 'd) + "%b" + (propertize "%b" 'e 'f)))) + (should (equal-including-properties + (format-spec fmt '((?b . "asd") (?a . "fgh"))) + #("fgh%asdasd" 0 3 (a b) 3 4 (c d) 7 10 (e f)))))) -(ert-deftest test-format-unknown () +(ert-deftest format-spec-unknown () (should-error (format-spec "foo %b %z zot" '((?b . "bar")))) + (should-error (format-spec "foo %b %%%z zot" '((?b . "bar")))) (should (equal (format-spec "foo %b %z zot" '((?b . "bar")) t) "foo bar %z zot")) - (should (equal (format-spec "foo %b %z %% zot" '((?b . "bar")) t) - "foo bar %z %% zot"))) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) t) + "foo bar %%%4z %%4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'ignore) + "foo bar %%4z %4 zot")) + (should (equal (format-spec "foo %4b %%%4z %%4 zot" '((?b . "bar")) 'delete) + "foo bar % %4 zot"))) -(ert-deftest test-format-modifiers () +(ert-deftest format-spec-flags () (should (equal (format-spec "foo %10b zot" '((?b . "bar"))) "foo bar zot")) (should (equal (format-spec "foo % 10b zot" '((?b . "bar"))) diff --git a/test/lisp/gnus/gnus-tests.el b/test/lisp/gnus/gnus-tests.el index d18b3fbed0f..fb1b204f042 100644 --- a/test/lisp/gnus/gnus-tests.el +++ b/test/lisp/gnus/gnus-tests.el @@ -1,4 +1,4 @@ -;;; gnus-tests.el --- Wrapper for the Gnus tests +;;; gnus-tests.el --- Wrapper for the Gnus tests -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/help-fns-tests.el b/test/lisp/help-fns-tests.el index 4c808d8372e..d2dc3d24aec 100644 --- a/test/lisp/help-fns-tests.el +++ b/test/lisp/help-fns-tests.el @@ -56,28 +56,28 @@ Return first line of the output of (describe-function-1 FUNC)." (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-macro () - (let ((regexp "a Lisp macro in .subr\.el") + (let ((regexp "a Lisp macro in .subr\\.el") (result (help-fns-tests--describe-function 'when))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defun () - (let ((regexp "a compiled Lisp function in .subr\.el") + (let ((regexp "a compiled Lisp function in .subr\\.el") (result (help-fns-tests--describe-function 'last))) (should (string-match regexp result)))) (ert-deftest help-fns-test-lisp-defsubst () - (let ((regexp "a compiled Lisp function in .subr\.el") + (let ((regexp "a compiled Lisp function in .subr\\.el") (result (help-fns-tests--describe-function 'posn-window))) (should (string-match regexp result)))) (ert-deftest help-fns-test-alias-to-defun () - (let ((regexp "an alias for .set-file-modes. in .subr\.el") + (let ((regexp "an alias for .set-file-modes. in .subr\\.el") (result (help-fns-tests--describe-function 'chmod))) (should (string-match regexp result)))) (ert-deftest help-fns-test-bug23887 () "Test for https://debbugs.gnu.org/23887 ." - (let ((regexp "an alias for .re-search-forward. in .subr\.el") + (let ((regexp "an alias for .re-search-forward. in .subr\\.el") (result (help-fns-tests--describe-function 'search-forward-regexp))) (should (string-match regexp result)))) @@ -123,4 +123,41 @@ Return first line of the output of (describe-function-1 FUNC)." (goto-char (point-min)) (should (looking-at "^font-lock-comment-face is ")))) + +;;; Tests for describe-keymap +(ert-deftest help-fns-test-find-keymap-name () + (should (equal (help-fns-find-keymap-name lisp-mode-map) 'lisp-mode-map)) + ;; Follow aliasing. + (unwind-protect + (progn + (defvaralias 'foo-test-map 'lisp-mode-map) + (should (equal (help-fns-find-keymap-name foo-test-map) 'lisp-mode-map))) + (makunbound 'foo-test-map))) + +(ert-deftest help-fns-test-describe-keymap/symbol () + (describe-keymap 'minibuffer-local-must-match-map) + (with-current-buffer "*Help*" + (should (looking-at "^minibuffer-local-must-match-map is")))) + +(ert-deftest help-fns-test-describe-keymap/value () + (describe-keymap minibuffer-local-must-match-map) + (with-current-buffer "*Help*" + (should (looking-at "^key")))) + +(ert-deftest help-fns-test-describe-keymap/not-keymap () + (should-error (describe-keymap nil)) + (should-error (describe-keymap emacs-version))) + +(ert-deftest help-fns-test-describe-keymap/let-bound () + (let ((foobar minibuffer-local-must-match-map)) + (describe-keymap foobar) + (with-current-buffer "*Help*" + (should (looking-at "^key"))))) + +(ert-deftest help-fns-test-describe-keymap/dynamically-bound-no-file () + (setq help-fns-test--describe-keymap-foo minibuffer-local-must-match-map) + (describe-keymap 'help-fns-test--describe-keymap-foo) + (with-current-buffer "*Help*" + (should (looking-at "^help-fns-test--describe-keymap-foo is")))) + ;;; help-fns-tests.el ends here diff --git a/test/lisp/help-mode-tests.el b/test/lisp/help-mode-tests.el new file mode 100644 index 00000000000..2b9552a8d81 --- /dev/null +++ b/test/lisp/help-mode-tests.el @@ -0,0 +1,169 @@ +;;; help-mode-tests.el --- Tests for help-mode.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'help-mode) +(require 'pp) + +(ert-deftest help-mode-tests-help-buffer () + (let ((help-xref-following nil)) + (should (equal "*Help*" (help-buffer))))) + +(ert-deftest help-mode-tests-help-buffer-current-buffer () + (with-temp-buffer + (help-mode) + (let ((help-xref-following t)) + (should (equal (buffer-name (current-buffer)) + (help-buffer)))))) + +(ert-deftest help-mode-tests-help-buffer-current-buffer-error () + (with-temp-buffer + (let ((help-xref-following t)) + (should-error (help-buffer))))) + +(ert-deftest help-mode-tests-make-xrefs () + (with-temp-buffer + (insert "car is a built-in function in ‘C source code’. + +(car LIST) + + Probably introduced at or before Emacs version 1.2. + This function does not change global state, including the match data. + +Return the car of LIST. If arg is nil, return nil. +Error if arg is not nil and not a cons cell. See also ‘car-safe’. + +See Info node ‘(elisp)Cons Cells’ for a discussion of related basic +Lisp concepts such as car, cdr, cons cell and list.") + (help-mode) + (help-make-xrefs) + (let ((car-safe-button (button-at 298))) + (should (eq (button-type car-safe-button) 'help-symbol)) + (should (eq (button-get car-safe-button 'help-function) + #'describe-symbol))) + (let ((cons-cells-info-button (button-at 333))) + (should (eq (button-type cons-cells-info-button) 'help-info)) + (should (eq (button-get cons-cells-info-button 'help-function) + #'info))))) + +(ert-deftest help-mode-tests-xref-button () + (with-temp-buffer + (insert "See also the function ‘interactive’.") + (string-match help-xref-symbol-regexp (buffer-string)) + (help-xref-button 8 'help-function) + (should-not (button-at 22)) + (should-not (button-at 35)) + (let ((button (button-at 30))) + (should (eq (button-type button) 'help-function))))) + +(ert-deftest help-mode-tests-insert-xref-button () + (with-temp-buffer + (help-insert-xref-button "[back]" 'help-back) + (goto-char (point-min)) + (should (eq (button-type (button-at (point))) 'help-back)) + (help-insert-xref-button "[forward]" 'help-forward) + ;; The back button should stay unchanged. + (should (eq (button-type (button-at (point))) 'help-back)))) + +(ert-deftest help-mode-tests-xref-on-pp () + (with-temp-buffer + (insert (pp '(cons fill-column))) + (help-xref-on-pp (point-min) (point-max)) + (goto-char (point-min)) + (search-forward "co") + (should (eq (button-type (button-at (point))) 'help-function)) + (search-forward "-") + (should (eq (button-type (button-at (point))) 'help-variable)))) + +(ert-deftest help-mode-tests-xref-go-back () + (let ((help-xref-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-xref-go-back (current-buffer)) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-xref-go-forward () + (let ((help-xref-forward-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-xref-go-forward (current-buffer)) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-back () + (let ((help-xref-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-go-back) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-back-no-stack () + (let ((help-xref-stack '())) + (should-error (help-go-back)))) + +(ert-deftest help-mode-tests-go-forward () + (let ((help-xref-forward-stack + `((2 ,(lambda () (erase-buffer) (insert "bar")))))) + (with-temp-buffer + (insert "foo") + (help-go-forward) + (should (= (point) 2)) + (should (equal (buffer-string) "bar"))))) + +(ert-deftest help-mode-tests-go-forward-no-stack () + (let ((help-xref-forward-stack '())) + (should-error (help-go-forward)))) + +(ert-deftest help-mode-tests-do-xref () + (with-temp-buffer + (help-mode) + (help-do-xref 0 #'describe-symbol '(car)) + (should (looking-at-p "car is a")) + (should (string-match-p "[back]" (buffer-string))))) + +(ert-deftest help-mode-tests-follow-symbol () + (with-temp-buffer + (insert "car") + (help-mode) + (help-follow-symbol 0) + (should (looking-at-p "car is a")) + (should (string-match-p "[back]" (buffer-string))))) + +(ert-deftest help-mode-tests-follow-symbol-no-symbol () + (with-temp-buffer + (insert "fXYEWnRHI0B9w6VJqQIw") + (help-mode) + (should-error (help-follow-symbol 0)))) + +(provide 'help-mode-tests) +;;; help-mode-tests.el ends here diff --git a/test/lisp/hi-lock-tests.el b/test/lisp/hi-lock-tests.el index dd2c28053a0..59f3e73b17d 100644 --- a/test/lisp/hi-lock-tests.el +++ b/test/lisp/hi-lock-tests.el @@ -48,5 +48,161 @@ ;; Only one match, then we have used just 1 face (should (equal hi-lock--unused-faces (cdr faces)))))) +(ert-deftest hi-lock-case-fold () + "Test for case-sensitivity." + (let ((hi-lock-auto-select-face t)) + (with-temp-buffer + (insert "a A b B\n") + + (dotimes (_ 2) (highlight-regexp "[a]")) + (should (= (length (overlays-in (point-min) (point-max))) 2)) + (unhighlight-regexp "[a]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[a]" nil nil "a")) + (should (= (length (overlays-in (point-min) (point-max))) 2)) + (unhighlight-regexp "a") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[A]" )) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "[A]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-regexp "[A]" nil nil "A")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "A") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]"))) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "[a]") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (dotimes (_ 2) (highlight-phrase "a a")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (unhighlight-regexp "a a") + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) + (should (= (length (overlays-in (point-min) (point-max))) 1)) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults)))) + (call-interactively 'unhighlight-regexp)) + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (emacs-lisp-mode) + (setq font-lock-mode t) + + (dotimes (_ 2) (highlight-regexp "[a]")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[a]")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[a]" nil nil "a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "a")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[A]" )) + (font-lock-ensure) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[A]")) + (should (null (get-text-property 3 'face))) + + (dotimes (_ 2) (highlight-regexp "[A]" nil nil "A")) + (font-lock-ensure) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "A")) + (should (null (get-text-property 3 'face))) + + (let ((case-fold-search nil)) (dotimes (_ 2) (highlight-regexp "[a]"))) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (null (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "[a]")) + (should (null (get-text-property 1 'face))) + + (dotimes (_ 2) (highlight-phrase "a a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp "a a")) + (should (null (get-text-property 1 'face))) + + (let ((search-spaces-regexp search-whitespace-regexp)) (highlight-regexp "a a")) + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults))) + (font-lock-fontified t)) + (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 1 'face)))))) + +(ert-deftest hi-lock-unhighlight () + "Test for unhighlighting and `hi-lock--regexps-at-point'." + (let ((hi-lock-auto-select-face t)) + (with-temp-buffer + (insert "aAbB\n") + + (cl-letf (((symbol-function 'completing-read) + (lambda (_prompt _coll _x _y _z _hist defaults) + (car defaults)))) + + (highlight-regexp "a") + (highlight-regexp "b") + (should (= (length (overlays-in (point-min) (point-max))) 4)) + ;; `hi-lock--regexps-at-point' should take regexp "a" at point 1, + ;; not the last regexp "b" + (goto-char 1) + (call-interactively 'unhighlight-regexp) + (should (= (length (overlays-in 1 3)) 0)) + (should (= (length (overlays-in 3 5)) 2)) + ;; Next call should unhighlight remaining regepxs + (call-interactively 'unhighlight-regexp) + (should (= (length (overlays-in 3 5)) 0)) + + ;; Test unhighlight all + (highlight-regexp "a") + (highlight-regexp "b") + (should (= (length (overlays-in (point-min) (point-max))) 4)) + (unhighlight-regexp t) + (should (= (length (overlays-in (point-min) (point-max))) 0)) + + (emacs-lisp-mode) + (setq font-lock-mode t) + + (highlight-regexp "a") + (highlight-regexp "b") + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + ;; `hi-lock--regexps-at-point' should take regexp "a" at point 1, + ;; not the last regexp "b" + (goto-char 1) + (let ((font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + ;; Next call should unhighlight remaining regepxs + (let ((font-lock-fontified t)) (call-interactively 'unhighlight-regexp)) + (should (null (get-text-property 3 'face))) + + ;; Test unhighlight all + (highlight-regexp "a") + (highlight-regexp "b") + (font-lock-ensure) + (should (memq 'hi-yellow (get-text-property 1 'face))) + (should (memq 'hi-yellow (get-text-property 3 'face))) + (let ((font-lock-fontified t)) (unhighlight-regexp t)) + (should (null (get-text-property 1 'face))) + (should (null (get-text-property 3 'face))))))) + (provide 'hi-lock-tests) ;;; hi-lock-tests.el ends here diff --git a/test/lisp/ibuffer-tests.el b/test/lisp/ibuffer-tests.el index 8dadb920547..2211cae305b 100644 --- a/test/lisp/ibuffer-tests.el +++ b/test/lisp/ibuffer-tests.el @@ -82,7 +82,7 @@ (test1 '((mode . org-mode) (or (size-gt . 10000) (and (not (starred-name)) - (directory . "\<org\>"))))) + (directory . "<org>"))))) (test2 '((or (mode . emacs-lisp-mode) (file-extension . "elc?") (and (starred-name) (name . "elisp")) (mode . lisp-interaction-mode)))) diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el index e66b5c6803d..66098fa0116 100644 --- a/test/lisp/image/gravatar-tests.el +++ b/test/lisp/image/gravatar-tests.el @@ -67,6 +67,6 @@ (gravatar-force-default nil) (gravatar-size nil)) (should (equal (gravatar-build-url "foo") "\ -https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) +https://seccdn.libravatar.org/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) ;;; gravatar-tests.el ends here diff --git a/test/lisp/imenu-tests.el b/test/lisp/imenu-tests.el index 684a856fe04..e5cdb9e65d1 100644 --- a/test/lisp/imenu-tests.el +++ b/test/lisp/imenu-tests.el @@ -1,4 +1,4 @@ -;;; imenu-tests.el --- Test suite for imenu. +;;; imenu-tests.el --- Test suite for imenu. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -50,24 +50,23 @@ (setq input (cdr input))))) result)) -(defmacro imenu-simple-scan-deftest (name doc major-mode content expected-items) +(defmacro imenu-simple-scan-deftest (name doc mode content expected-items) "Generate an ert test for mode-own imenu expression. Run `imenu-create-index-function' at the buffer which content is -CONTENT with MAJOR-MODE. A generated test runs `imenu-create-index-function' -at the buffer which content is CONTENT with MAJOR-MODE. Then it compares a list -of strings which are picked up from the result with EXPECTED-ITEMS." +CONTENT with major MODE. A generated test runs `imenu-create-index-function' +at the buffer which content is CONTENT with major MODE. Then it compares a +list of strings which are picked up from the result with EXPECTED-ITEMS." (let ((xname (intern (concat "imenu-simple-scan-deftest-" (symbol-name name))))) `(ert-deftest ,xname () - ,doc + ,doc (with-temp-buffer (insert ,content) - (funcall ',major-mode) + (funcall #',mode) (let ((result-items (sort (imenu-simple-scan-deftest-gather-strings-from-list (funcall imenu-create-index-function)) #'string-lessp)) (expected-items (sort (copy-sequence ,expected-items) #'string-lessp))) - (should (equal result-items expected-items)) - ))))) + (should (equal result-items expected-items))))))) (imenu-simple-scan-deftest sh "Test imenu expression for sh-mode." sh-mode "a() { diff --git a/test/lisp/info-xref-tests.el b/test/lisp/info-xref-tests.el index 128b3f25ca5..940aa7d8ad1 100644 --- a/test/lisp/info-xref-tests.el +++ b/test/lisp/info-xref-tests.el @@ -1,4 +1,4 @@ -;;; info-xref.el --- tests for info-xref.el +;;; info-xref.el --- tests for info-xref.el -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/lisp/international/ccl-tests.el b/test/lisp/international/ccl-tests.el index c8a5512d6f0..9277d0162e8 100644 --- a/test/lisp/international/ccl-tests.el +++ b/test/lisp/international/ccl-tests.el @@ -1,3 +1,5 @@ +;;; ccl-tests.el --- unit tests for ccl.el -*- lexical-binding:t -*- + ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. ;; This file is part of GNU Emacs. diff --git a/test/lisp/international/mule-tests.el b/test/lisp/international/mule-tests.el index 91e3c2279f0..5f8e653d7c2 100644 --- a/test/lisp/international/mule-tests.el +++ b/test/lisp/international/mule-tests.el @@ -48,6 +48,27 @@ (append (kbd "C-x RET c u t f - 8 RET C-u C-u c a b RET") nil))) (read-string "prompt:"))))) +(ert-deftest mule-utf-7 () + ;; utf-7 and utf-7-imap are not ASCII-compatible. + (should-not (coding-system-get 'utf-7 :ascii-compatible-p)) + (should-not (coding-system-get 'utf-7-imap :ascii-compatible-p)) + ;; Invariant ASCII subset. + (let ((s (apply #'string (append (number-sequence #x20 #x25) + (number-sequence #x27 #x7e))))) + (should (equal (encode-coding-string s 'utf-7-imap) s)) + (should (equal (decode-coding-string s 'utf-7-imap) s))) + ;; Escaped ampersand. + (should (equal (encode-coding-string "a&bcd" 'utf-7-imap) "a&-bcd")) + (should (equal (decode-coding-string "a&-bcd" 'utf-7-imap) "a&bcd")) + ;; Ability to encode Unicode. + (should (equal (check-coding-systems-region "あ" nil '(utf-7-imap)) nil)) + (should (equal (encode-coding-string "あ" 'utf-7-imap) "&MEI-")) + (should (equal (decode-coding-string "&MEI-" 'utf-7-imap) "あ"))) + +(ert-deftest mule-hz () + ;; The chinese-hz encoding is not ASCII compatible. + (should-not (coding-system-get 'chinese-hz :ascii-compatible-p))) + ;; Stop "Local Variables" above causing confusion when visiting this file. diff --git a/test/lisp/international/mule-util-tests.el b/test/lisp/international/mule-util-tests.el index c571782d635..cc199bd4972 100644 --- a/test/lisp/international/mule-util-tests.el +++ b/test/lisp/international/mule-util-tests.el @@ -1,4 +1,4 @@ -;;; mule-util --- tests for international/mule-util.el +;;; mule-util-tests.el --- tests for international/mule-util.el -*- lexical-binding:t -*- ;; Copyright (C) 2002-2020 Free Software Foundation, Inc. @@ -81,4 +81,4 @@ (dotimes (i (length mule-util-test-truncate-data)) (mule-util-test-truncate-create i)) -;;; mule-util.el ends here +;;; mule-util-tests.el ends here diff --git a/test/lisp/international/ucs-normalize-tests.el b/test/lisp/international/ucs-normalize-tests.el index 03366065ce6..2c60bd318a2 100644 --- a/test/lisp/international/ucs-normalize-tests.el +++ b/test/lisp/international/ucs-normalize-tests.el @@ -307,7 +307,7 @@ implementations: (list " var var)) (dolist (linos (seq-partition newval 8)) (insert (mapconcat #'number-to-string linos " ") "\n")) - (insert ")\)")) + (insert "))")) (defun ucs-normalize-check-failing-lines () (interactive) @@ -341,4 +341,15 @@ implementations: (display-buffer (current-buffer))) (message "No changes to failing lines needed")))) +(ert-deftest ucs-normalize-save-match-data () + "Verify that match data isn't clobbered (bug#41445)" + (string-match (rx (+ digit)) "a47b") + (should (equal (match-data t) '(1 3))) + (should (equal + (decode-coding-string + (encode-coding-string "Käsesoßenrührlöffel" 'utf-8-hfs) + 'utf-8-hfs) + "Käsesoßenrührlöffel")) + (should (equal (match-data t) '(1 3)))) + ;;; ucs-normalize-tests.el ends here diff --git a/test/lisp/jit-lock-tests.el b/test/lisp/jit-lock-tests.el index 445716c14b9..dfa74cf35e7 100644 --- a/test/lisp/jit-lock-tests.el +++ b/test/lisp/jit-lock-tests.el @@ -1,4 +1,4 @@ -;;; jit-lock-tests.el --- tests for jit-lock +;;; jit-lock-tests.el --- tests for jit-lock -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/json-tests.el b/test/lisp/json-tests.el index 05837e83f90..a0e8c87c7b3 100644 --- a/test/lisp/json-tests.el +++ b/test/lisp/json-tests.el @@ -1,4 +1,4 @@ -;;; json-tests.el --- Test suite for json.el +;;; json-tests.el --- Test suite for json.el -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -21,11 +21,16 @@ (require 'ert) (require 'json) +(require 'map) +(require 'seq) + +(eval-when-compile + (require 'cl-lib)) (defmacro json-tests--with-temp-buffer (content &rest body) "Create a temporary buffer with CONTENT and evaluate BODY there. Point is moved to beginning of the buffer." - (declare (indent 1)) + (declare (debug t) (indent 1)) `(with-temp-buffer (insert ,content) (goto-char (point-min)) @@ -33,66 +38,107 @@ Point is moved to beginning of the buffer." ;;; Utilities -(ert-deftest test-json-join () - (should (equal (json-join '() ", ") "")) - (should (equal (json-join '("a" "b" "c") ", ") "a, b, c"))) - (ert-deftest test-json-alist-p () (should (json-alist-p '())) - (should (json-alist-p '((a 1) (b 2) (c 3)))) - (should (json-alist-p '((:a 1) (:b 2) (:c 3)))) - (should (json-alist-p '(("a" 1) ("b" 2) ("c" 3)))) + (should (json-alist-p '((())))) + (should (json-alist-p '((a)))) + (should (json-alist-p '((a . 1)))) + (should (json-alist-p '((a . 1) (b 2) (c)))) + (should (json-alist-p '((:a) (:b 2) (:c . 3)))) + (should (json-alist-p '(("a" . 1) ("b" 2) ("c")))) + (should-not (json-alist-p '(()))) + (should-not (json-alist-p '(a))) + (should-not (json-alist-p '(a . 1))) + (should-not (json-alist-p '((a . 1) . []))) + (should-not (json-alist-p '((a . 1) []))) (should-not (json-alist-p '(:a :b :c))) (should-not (json-alist-p '(:a 1 :b 2 :c 3))) - (should-not (json-alist-p '((:a 1) (:b 2) 3)))) + (should-not (json-alist-p '((:a 1) (:b 2) 3))) + (should-not (json-alist-p '((:a 1) (:b 2) ()))) + (should-not (json-alist-p '(((a) 1) (b 2) (c 3)))) + (should-not (json-alist-p [])) + (should-not (json-alist-p [(a . 1)])) + (should-not (json-alist-p #s(hash-table)))) (ert-deftest test-json-plist-p () (should (json-plist-p '())) + (should (json-plist-p '(:a 1))) (should (json-plist-p '(:a 1 :b 2 :c 3))) + (should (json-plist-p '(:a :b))) + (should (json-plist-p '(:a :b :c :d))) + (should-not (json-plist-p '(a))) + (should-not (json-plist-p '(a 1))) (should-not (json-plist-p '(a 1 b 2 c 3))) (should-not (json-plist-p '("a" 1 "b" 2 "c" 3))) + (should-not (json-plist-p '(:a))) (should-not (json-plist-p '(:a :b :c))) - (should-not (json-plist-p '((:a 1) (:b 2) (:c 3))))) - -(ert-deftest test-json-plist-reverse () - (should (equal (json--plist-reverse '()) '())) - (should (equal (json--plist-reverse '(:a 1)) '(:a 1))) - (should (equal (json--plist-reverse '(:a 1 :b 2 :c 3)) + (should-not (json-plist-p '(:a 1 :b 2 :c))) + (should-not (json-plist-p '((:a 1)))) + (should-not (json-plist-p '((:a 1) (:b 2) (:c 3)))) + (should-not (json-plist-p [])) + (should-not (json-plist-p [:a 1])) + (should-not (json-plist-p #s(hash-table)))) + +(ert-deftest test-json-plist-nreverse () + (should (equal (json--plist-nreverse '()) '())) + (should (equal (json--plist-nreverse (list :a 1)) '(:a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2)) '(:b 2 :a 1))) + (should (equal (json--plist-nreverse (list :a 1 :b 2 :c 3)) '(:c 3 :b 2 :a 1)))) -(ert-deftest test-json-plist-to-alist () - (should (equal (json--plist-to-alist '()) '())) - (should (equal (json--plist-to-alist '(:a 1)) '((:a . 1)))) - (should (equal (json--plist-to-alist '(:a 1 :b 2 :c 3)) - '((:a . 1) (:b . 2) (:c . 3))))) - (ert-deftest test-json-advance () (json-tests--with-temp-buffer "{ \"a\": 1 }" (json-advance 0) - (should (= (point) (point-min))) + (should (bobp)) + (json-advance) + (should (= (point) (1+ (point-min)))) + (json-advance 0) + (should (= (point) (1+ (point-min)))) + (json-advance 1) + (should (= (point) (+ (point-min) 2))) (json-advance 3) - (should (= (point) (+ (point-min) 3))))) + (should (= (point) (+ (point-min) 5))))) (ert-deftest test-json-peek () (json-tests--with-temp-buffer "" (should (zerop (json-peek)))) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-peek) ?{)))) + (should (= (json-peek) ?\{)) + (goto-char (1- (point-max))) + (should (= (json-peek) ?\})) + (json-advance) + (should (zerop (json-peek))))) (ert-deftest test-json-pop () (json-tests--with-temp-buffer "" (should-error (json-pop) :type 'json-end-of-file)) (json-tests--with-temp-buffer "{ \"a\": 1 }" - (should (equal (json-pop) ?{)) - (should (= (point) (+ (point-min) 1))))) + (should (= (json-pop) ?\{)) + (should (= (point) (1+ (point-min)))) + (goto-char (1- (point-max))) + (should (= (json-pop) ?\})) + (should-error (json-pop) :type 'json-end-of-file))) (ert-deftest test-json-skip-whitespace () + (json-tests--with-temp-buffer "" + (json-skip-whitespace) + (should (bobp)) + (should (eobp))) + (json-tests--with-temp-buffer "{}" + (json-skip-whitespace) + (should (bobp)) + (json-advance) + (json-skip-whitespace) + (should (= (point) (1+ (point-min)))) + (json-advance) + (json-skip-whitespace) + (should (eobp))) (json-tests--with-temp-buffer "\t\r\n\f\b { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?\f))) + (should (= (json-peek) ?\f))) (json-tests--with-temp-buffer "\t\r\n\t { \"a\": 1 }" (json-skip-whitespace) - (should (equal (char-after) ?{)))) + (should (= (json-peek) ?\{)))) ;;; Paths @@ -113,59 +159,243 @@ Point is moved to beginning of the buffer." (ert-deftest test-json-path-to-position-no-match () (let* ((json-string "{\"foo\": {\"bar\": \"baz\"}}") (matched-path (json-path-to-position 5 json-string))) - (should (null matched-path)))) + (should-not matched-path))) ;;; Keywords (ert-deftest test-json-read-keyword () (json-tests--with-temp-buffer "true" - (should (json-read-keyword "true"))) + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true " + (should (eq (json-read-keyword "true") t)) + (should (eobp))) + (json-tests--with-temp-buffer "true}" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 4)))) + (json-tests--with-temp-buffer "true false" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true }" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "true |" + (should (eq (json-read-keyword "true") t)) + (should (= (point) (+ (point-min) 5)))) + (json-tests--with-temp-buffer "false" + (let ((json-false 'false)) + (should (eq (json-read-keyword "false") 'false))) + (should (eobp))) + (json-tests--with-temp-buffer "null" + (let ((json-null 'null)) + (should (eq (json-read-keyword "null") 'null))) + (should (eobp)))) + +(ert-deftest test-json-read-keyword-invalid () + (json-tests--with-temp-buffer "" + (should (equal (should-error (json-read-keyword "")) + '(json-unknown-keyword ""))) + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) (json-tests--with-temp-buffer "true" - (should-error - (json-read-keyword "false") :type 'json-unknown-keyword)) + (should (equal (should-error (json-read-keyword "false")) + '(json-unknown-keyword "true")))) (json-tests--with-temp-buffer "foo" - (should-error - (json-read-keyword "foo") :type 'json-unknown-keyword))) + (should (equal (should-error (json-read-keyword "foo")) + '(json-unknown-keyword "foo"))) + (should (equal (should-error (json-read-keyword "bar")) + '(json-unknown-keyword "bar")))) + (json-tests--with-temp-buffer " true" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword ())))) + (json-tests--with-temp-buffer "truefalse" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "truefalse")))) + (json-tests--with-temp-buffer "true|" + (should (equal (should-error (json-read-keyword "true")) + '(json-unknown-keyword "true"))))) (ert-deftest test-json-encode-keyword () (should (equal (json-encode-keyword t) "true")) - (should (equal (json-encode-keyword json-false) "false")) - (should (equal (json-encode-keyword json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode-keyword 'false) "false")) + (should (equal (json-encode-keyword json-false) "false"))) + (let ((json-null 'null)) + (should (equal (json-encode-keyword 'null) "null")) + (should (equal (json-encode-keyword json-null) "null")))) ;;; Numbers -(ert-deftest test-json-read-number () - (json-tests--with-temp-buffer "3" - (should (= (json-read-number) 3))) - (json-tests--with-temp-buffer "-5" - (should (= (json-read-number) -5))) - (json-tests--with-temp-buffer "123.456" - (should (= (json-read-number) 123.456))) - (json-tests--with-temp-buffer "1e3" - (should (= (json-read-number) 1e3))) - (json-tests--with-temp-buffer "2e+3" - (should (= (json-read-number) 2e3))) - (json-tests--with-temp-buffer "3E3" - (should (= (json-read-number) 3e3))) - (json-tests--with-temp-buffer "1e-7" - (should (= (json-read-number) 1e-7))) - (json-tests--with-temp-buffer "abc" - (should-error (json-read-number) :type 'json-number-format))) +(ert-deftest test-json-read-integer () + (json-tests--with-temp-buffer "0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0 " + (should (= (json-read-number) 0)) + (should (eobp))) + (json-tests--with-temp-buffer "3 " + (should (= (json-read-number) 3)) + (should (eobp))) + (json-tests--with-temp-buffer "-10 " + (should (= (json-read-number) -10)) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1+ most-positive-fixnum)) + (should (= (json-read-number) (1+ most-positive-fixnum))) + (should (eobp))) + (json-tests--with-temp-buffer (format "%d " (1- most-negative-fixnum)) + (should (= (json-read-number) (1- most-negative-fixnum))) + (should (eobp)))) + +(ert-deftest test-json-read-fraction () + (json-tests--with-temp-buffer "0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0 " + (should (= (json-read-number) 0.0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.01 " + (should (= (json-read-number) 0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.01 " + (should (= (json-read-number) -0.01)) + (should (eobp))) + (json-tests--with-temp-buffer "123.456 " + (should (= (json-read-number) 123.456)) + (should (eobp))) + (json-tests--with-temp-buffer "-123.456 " + (should (= (json-read-number) -123.456)) + (should (eobp)))) + +(ert-deftest test-json-read-exponent () + (json-tests--with-temp-buffer "0e0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0E+0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0e-0 " + (should (= (json-read-number) 0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "12e34 " + (should (= (json-read-number) 12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "-12E+34 " + (should (= (json-read-number) -12e34)) + (should (eobp))) + (json-tests--with-temp-buffer "12e-34 " + (should (= (json-read-number) 12e-34)) + (should (eobp)))) + +(ert-deftest test-json-read-fraction-exponent () + (json-tests--with-temp-buffer "0.0e0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-0.0E0 " + (should (= (json-read-number) 0.0e0)) + (should (eobp))) + (json-tests--with-temp-buffer "0.12E-0 " + (should (= (json-read-number) 0.12e0)) + (should (eobp))) + (json-tests--with-temp-buffer "-12.34e+56 " + (should (= (json-read-number) -12.34e+56)) + (should (eobp)))) + +(ert-deftest test-json-read-number-invalid () + (cl-flet ((read (str) + ;; Return error and point resulting from reading STR. + (json-tests--with-temp-buffer str + (cons (should-error (json-read-number)) (point))))) + ;; POS is where each of its STRINGS becomes invalid. + (pcase-dolist (`(,pos . ,strings) + '((1 "" "+" "-" "." "e" "e1" "abc" "++0" "++1" + "+0" "+0.0" "+12" "+12.34" "+12.34e56" + ".0" "+.0" "-.0" ".12" "+.12" "-.12" + ".e0" "+.e0" "-.e0" ".0e0" "+.0e0" "-.0e0") + (2 "01" "1ee1" "1e++1") + (3 "-01") + (4 "0.0.0" "1.1.1" "1e1e1") + (5 "-0.0.0" "-1.1.1"))) + ;; Expected error and point. + (let ((res `((json-number-format ,pos) . ,pos))) + (dolist (str strings) + (should (equal (read str) res))))))) (ert-deftest test-json-encode-number () + (should (equal (json-encode-number 0) "0")) + (should (equal (json-encode-number -0) "0")) (should (equal (json-encode-number 3) "3")) (should (equal (json-encode-number -5) "-5")) - (should (equal (json-encode-number 123.456) "123.456"))) + (should (equal (json-encode-number 123.456) "123.456")) + (let ((bignum (1+ most-positive-fixnum))) + (should (equal (json-encode-number bignum) + (number-to-string bignum))))) -;; Strings +;;; Strings (ert-deftest test-json-read-escaped-char () (json-tests--with-temp-buffer "\\\"" - (should (equal (json-read-escaped-char) ?\")))) + (should (= (json-read-escaped-char) ?\")) + (should (eobp))) + (json-tests--with-temp-buffer "\\\\ " + (should (= (json-read-escaped-char) ?\\)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\b " + (should (= (json-read-escaped-char) ?\b)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\f " + (should (= (json-read-escaped-char) ?\f)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\n " + (should (= (json-read-escaped-char) ?\n)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\r " + (should (= (json-read-escaped-char) ?\r)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\t " + (should (= (json-read-escaped-char) ?\t)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\x " + (should (= (json-read-escaped-char) ?x)) + (should (= (point) (+ (point-min) 2)))) + (json-tests--with-temp-buffer "\\ud800\\uDC00 " + (should (= (json-read-escaped-char) #x10000)) + (should (= (point) (+ (point-min) 12)))) + (json-tests--with-temp-buffer "\\ud7ff\\udc00 " + (should (= (json-read-escaped-char) #xd7ff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\uffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6)))) + (json-tests--with-temp-buffer "\\ufffff " + (should (= (json-read-escaped-char) #xffff)) + (should (= (point) (+ (point-min) 6))))) + +(ert-deftest test-json-read-escaped-char-invalid () + (json-tests--with-temp-buffer "" + (should-error (json-read-escaped-char))) + (json-tests--with-temp-buffer "\\" + (should-error (json-read-escaped-char) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "\\ufff " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2))))) + (json-tests--with-temp-buffer "\\ufffg " + (should (equal (should-error (json-read-escaped-char)) + (list 'json-string-escape (+ (point-min) 2)))))) (ert-deftest test-json-read-string () + (json-tests--with-temp-buffer "" + (should-error (json-read-string))) (json-tests--with-temp-buffer "\"formfeed\f\"" - (should-error (json-read-string) :type 'json-string-format)) + (should (equal (should-error (json-read-string)) + '(json-string-format ?\f)))) + (json-tests--with-temp-buffer "\"\"" + (should (equal (json-read-string) ""))) (json-tests--with-temp-buffer "\"foo \\\"bar\\\"\"" (should (equal (json-read-string) "foo \"bar\""))) (json-tests--with-temp-buffer "\"abcαβγ\"" @@ -175,57 +405,117 @@ Point is moved to beginning of the buffer." ;; Bug#24784 (json-tests--with-temp-buffer "\"\\uD834\\uDD1E\"" (should (equal (json-read-string) "\U0001D11E"))) + (json-tests--with-temp-buffer "f" + (should-error (json-read-string) :type 'json-end-of-file)) (json-tests--with-temp-buffer "foo" - (should-error (json-read-string) :type 'json-string-format))) + (should-error (json-read-string) :type 'json-end-of-file))) (ert-deftest test-json-encode-string () + (should (equal (json-encode-string "") "\"\"")) + (should (equal (json-encode-string "a") "\"a\"")) (should (equal (json-encode-string "foo") "\"foo\"")) (should (equal (json-encode-string "a\n\fb") "\"a\\n\\fb\"")) (should (equal (json-encode-string "\nasdфыв\u001f\u007ffgh\t") "\"\\nasdфыв\\u001f\u007ffgh\\t\""))) (ert-deftest test-json-encode-key () + (should (equal (json-encode-key "") "\"\"")) + (should (equal (json-encode-key '##) "\"\"")) + (should (equal (json-encode-key :) "\"\"")) (should (equal (json-encode-key "foo") "\"foo\"")) (should (equal (json-encode-key 'foo) "\"foo\"")) (should (equal (json-encode-key :foo) "\"foo\"")) - (should-error (json-encode-key 5) :type 'json-key-format) - (should-error (json-encode-key ["foo"]) :type 'json-key-format) - (should-error (json-encode-key '("foo")) :type 'json-key-format)) + (should (equal (should-error (json-encode-key 5)) + '(json-key-format 5))) + (should (equal (should-error (json-encode-key ["foo"])) + '(json-key-format ["foo"]))) + (should (equal (should-error (json-encode-key '("foo"))) + '(json-key-format ("foo"))))) ;;; Objects (ert-deftest test-json-new-object () (let ((json-object-type 'alist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let ((json-object-type 'plist)) - (should (equal (json-new-object) '()))) + (should-not (json-new-object))) (let* ((json-object-type 'hash-table) (json-object (json-new-object))) (should (hash-table-p json-object)) - (should (= (hash-table-count json-object) 0)))) + (should (map-empty-p json-object)) + (should (eq (hash-table-test json-object) #'equal)))) -(ert-deftest test-json-add-to-object () +(ert-deftest test-json-add-to-alist () (let* ((json-object-type 'alist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (equal (assq 'a obj) '(a . 1))) - (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (equal (assq 'a obj) '(a . 1))) + (should (equal (assq 'b obj) '(b . 2)))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (equal (assq 'c obj) '(c . 3))) + (should (equal (assq 'd obj) '(d . 4)))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (equal (assq :e obj) '(:e . 5))) + (should (equal (assq :f obj) '(:f . 6)))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (equal (assoc "g" obj) '("g" . 7))) + (should (equal (assoc "h" obj) '("h" . 8)))))) + +(ert-deftest test-json-add-to-plist () (let* ((json-object-type 'plist) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (plist-get obj :a) 1)) - (should (= (plist-get obj :b) 2))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (plist-get obj :a) 1)) + (should (= (plist-get obj :b) 2))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (plist-get obj :c) 3)) + (should (= (plist-get obj :d) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (plist-get obj 'e) 5)) + (should (= (plist-get obj 'f) 6))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (lax-plist-get obj "g") 7)) + (should (= (lax-plist-get obj "h") 8))))) + +(ert-deftest test-json-add-to-hash-table () (let* ((json-object-type 'hash-table) - (json-key-type nil) (obj (json-new-object))) - (setq obj (json-add-to-object obj "a" 1)) - (setq obj (json-add-to-object obj "b" 2)) - (should (= (gethash "a" obj) 1)) - (should (= (gethash "b" obj) 2)))) + (let ((json-key-type nil)) + (setq obj (json-add-to-object obj "a" 1)) + (setq obj (json-add-to-object obj "b" 2)) + (should (= (gethash "a" obj) 1)) + (should (= (gethash "b" obj) 2))) + (let ((json-key-type 'string)) + (setq obj (json-add-to-object obj "c" 3)) + (setq obj (json-add-to-object obj "d" 4)) + (should (= (gethash "c" obj) 3)) + (should (= (gethash "d" obj) 4))) + (let ((json-key-type 'symbol)) + (setq obj (json-add-to-object obj "e" 5)) + (setq obj (json-add-to-object obj "f" 6)) + (should (= (gethash 'e obj) 5)) + (should (= (gethash 'f obj) 6))) + (let ((json-key-type 'keyword)) + (setq obj (json-add-to-object obj "g" 7)) + (setq obj (json-add-to-object obj "h" 8)) + (should (= (gethash :g obj) 7)) + (should (= (gethash :h obj) 8))))) (ert-deftest test-json-read-object () (json-tests--with-temp-buffer "{ \"a\": 1, \"b\": 2 }" @@ -238,94 +528,384 @@ Point is moved to beginning of the buffer." (let* ((json-object-type 'hash-table) (hash-table (json-read-object))) (should (= (gethash "a" hash-table) 1)) - (should (= (gethash "b" hash-table) 2)))) + (should (= (gethash "b" hash-table) 2))))) + +(ert-deftest test-json-read-object-empty () + (json-tests--with-temp-buffer "{}" + (let ((json-object-type 'alist)) + (should-not (save-excursion (json-read-object)))) + (let ((json-object-type 'plist)) + (should-not (save-excursion (json-read-object)))) + (let* ((json-object-type 'hash-table) + (hash-table (json-read-object))) + (should (hash-table-p hash-table)) + (should (map-empty-p hash-table))))) + +(ert-deftest test-json-read-object-invalid () + (json-tests--with-temp-buffer "{ \"a\" 1, \"b\": 2 }" + (should (equal (should-error (json-read-object)) + '(json-object-format ":" ?1)))) (json-tests--with-temp-buffer "{ \"a\": 1 \"b\": 2 }" - (should-error (json-read-object) :type 'json-object-format))) + (should (equal (should-error (json-read-object)) + '(json-object-format "," ?\"))))) + +(ert-deftest test-json-read-object-function () + (let* ((pre nil) + (post nil) + (keys '("b" "a")) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "{ \"b\": 2, \"a\": 1 }" + (json-read-object) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-hash-table () - (let ((hash-table (make-hash-table)) - (json-encoding-object-sort-predicate 'string<) + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (puthash :a 1 hash-table) - (puthash :b 2 hash-table) - (puthash :c 3 hash-table) - (should (equal (json-encode hash-table) - "{\"a\":1,\"b\":2,\"c\":3}")))) - -(ert-deftest json-encode-simple-alist () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode '((a . 1) (b . 2))) - "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist () - (let ((plist '(:a 1 :b 2)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\"a\":1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\"a\":1,\"b\":2}" "{\"b\":2,\"a\":1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\"a\":1,\"b\":2,\"c\":3}" + "{\"a\":1,\"c\":3,\"b\":2}" + "{\"b\":2,\"a\":1,\"c\":3}" + "{\"b\":2,\"c\":3,\"a\":1}" + "{\"c\":3,\"a\":1,\"b\":2}" + "{\"c\":3,\"b\":2,\"a\":1}"))))) + +(ert-deftest test-json-encode-hash-table-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1\n}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1\n}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3\n}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2\n}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3\n}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1\n}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2\n}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}"))))) + +(ert-deftest test-json-encode-hash-table-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-hash-table #s(hash-table)) "{}")) + (should (equal (json-encode-hash-table #s(hash-table data (a 1))) + "{\n \"a\": 1}")) + (should (member (json-encode-hash-table #s(hash-table data (b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1}"))) + (should (member (json-encode-hash-table #s(hash-table data (c 3 b 2 a 1))) + '("{\n \"a\": 1,\n \"b\": 2,\n \"c\": 3}" + "{\n \"a\": 1,\n \"c\": 3,\n \"b\": 2}" + "{\n \"b\": 2,\n \"a\": 1,\n \"c\": 3}" + "{\n \"b\": 2,\n \"c\": 3,\n \"a\": 1}" + "{\n \"c\": 3,\n \"a\": 1,\n \"b\": 2}" + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}"))))) + +(ert-deftest test-json-encode-hash-table-sort () + (let ((json-encoding-object-sort-predicate #'string<) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2}")))) - -(ert-deftest test-json-encode-plist-with-sort-predicate () - (let ((plist '(:c 3 :a 1 :b 2)) - (json-encoding-object-sort-predicate 'string<) + (pcase-dolist (`(,in . ,out) + '((#s(hash-table) . "{}") + (#s(hash-table data (a 1)) . "{\"a\":1}") + (#s(hash-table data (b 2 a 1)) . "{\"a\":1,\"b\":2}") + (#s(hash-table data (c 3 b 2 a 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (map-pairs in))) + (should (equal (json-encode-hash-table in) out)) + ;; Ensure sorting isn't destructive. + (should (seq-set-equal-p (map-pairs in) copy)))))) + +(ert-deftest test-json-encode-alist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode plist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-alist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-alist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-alist ()) "{}")) + (should (equal (json-encode-alist '((a . 1))) "{\n \"a\": 1}")) + (should (equal (json-encode-alist '((b . 2) (a . 1))) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-alist '((c . 3) (b . 2) (a . 1))) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-alist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + (((a . 1)) . "{\"a\":1}") + (((b . 2) (a . 1)) . "{\"a\":1,\"b\":2}") + (((c . 3) (b . 2) (a . 1)) + . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-alist in))) + (should (equal (json-encode-alist in) out)) + ;; Ensure sorting isn't destructive (bug#40693). + (should (equal in copy)))))) -(ert-deftest test-json-encode-alist-with-sort-predicate () - (let ((alist '((:c . 3) (:a . 1) (:b . 2))) - (json-encoding-object-sort-predicate 'string<) +(ert-deftest test-json-encode-plist () + (let ((json-encoding-object-sort-predicate nil) (json-encoding-pretty-print nil)) - (should (equal (json-encode alist) "{\"a\":1,\"b\":2,\"c\":3}")))) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\"c\":3,\"b\":2,\"a\":1}")))) + +(ert-deftest test-json-encode-plist-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1\n}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1\n}")))) + +(ert-deftest test-json-encode-plist-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-plist ()) "{}")) + (should (equal (json-encode-plist '(:a 1)) "{\n \"a\": 1}")) + (should (equal (json-encode-plist '(:b 2 :a 1)) + "{\n \"b\": 2,\n \"a\": 1}")) + (should (equal (json-encode-plist '(:c 3 :b 2 :a 1)) + "{\n \"c\": 3,\n \"b\": 2,\n \"a\": 1}")))) + +(ert-deftest test-json-encode-plist-sort () + (let ((json-encoding-object-sort-predicate #'string<) + (json-encoding-pretty-print nil)) + (pcase-dolist (`(,in . ,out) + '((() . "{}") + ((:a 1) . "{\"a\":1}") + ((:b 2 :a 1) . "{\"a\":1,\"b\":2}") + ((:c 3 :b 2 :a 1) . "{\"a\":1,\"b\":2,\"c\":3}"))) + (let ((copy (copy-sequence in))) + (should (equal (json-encode-plist in) out)) + ;; Ensure sorting isn't destructive. + (should (equal in copy)))))) (ert-deftest test-json-encode-list () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-list '(:a 1 :b 2)) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '((:a . 1) (:b . 2))) - "{\"a\":1,\"b\":2}")) - (should (equal (json-encode-list '(1 2 3 4)) "[1,2,3,4]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-list ()) "{}")) + (should (equal (json-encode-list '(a)) "[\"a\"]")) + (should (equal (json-encode-list '(:a)) "[\"a\"]")) + (should (equal (json-encode-list '("a")) "[\"a\"]")) + (should (equal (json-encode-list '(a 1)) "[\"a\",1]")) + (should (equal (json-encode-list '("a" 1)) "[\"a\",1]")) + (should (equal (json-encode-list '(:a 1)) "{\"a\":1}")) + (should (equal (json-encode-list '((a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '((:a . 1))) "{\"a\":1}")) + (should (equal (json-encode-list '(:b 2 :a)) "[\"b\",2,\"a\"]")) + (should (equal (json-encode-list '(4 3 2 1)) "[4,3,2,1]")) + (should (equal (json-encode-list '(b 2 a 1)) "[\"b\",2,\"a\",1]")) + (should (equal (json-encode-list '(:b 2 :a 1)) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((b . 2) (a . 1))) "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((:b . 2) (:a . 1))) + "{\"b\":2,\"a\":1}")) + (should (equal (json-encode-list '((a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((:a) 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '(("a") 1)) "[[\"a\"],1]")) + (should (equal (json-encode-list '((a 1) 2)) "[[\"a\",1],2]")) + (should (equal (json-encode-list '((:a 1) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(((a . 1)) 2)) "[{\"a\":1},2]")) + (should (equal (json-encode-list '(:a 1 :b (2))) "{\"a\":1,\"b\":[2]}")) + (should (equal (json-encode-list '((a . 1) (b 2))) "{\"a\":1,\"b\":[2]}")) + (should-error (json-encode-list '(a . 1)) :type 'wrong-type-argument) + (should-error (json-encode-list '((a . 1) 2)) :type 'wrong-type-argument) + (should (equal (should-error (json-encode-list [])) + '(json-error []))) + (should (equal (should-error (json-encode-list [a])) + '(json-error [a]))))) ;;; Arrays (ert-deftest test-json-read-array () (let ((json-array-type 'vector)) + (json-tests--with-temp-buffer "[]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[ ]" + (should (equal (json-read-array) []))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) [1]))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) [1 2 "a" "b"])))) (let ((json-array-type 'list)) + (json-tests--with-temp-buffer "[]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[ ]" + (should-not (json-read-array))) + (json-tests--with-temp-buffer "[1]" + (should (equal (json-read-array) '(1)))) (json-tests--with-temp-buffer "[1, 2, \"a\", \"b\"]" (should (equal (json-read-array) '(1 2 "a" "b"))))) (json-tests--with-temp-buffer "[1 2]" - (should-error (json-read-array) :type 'json-error))) + (should (equal (should-error (json-read-array)) + '(json-array-format "," ?2))))) + +(ert-deftest test-json-read-array-function () + (let* ((pre nil) + (post nil) + (keys '(0 1)) + (json-pre-element-read-function + (lambda (key) + (setq pre 'pre) + (should (equal key (pop keys))))) + (json-post-element-read-function + (lambda () (setq post 'post)))) + (json-tests--with-temp-buffer "[1, 0]" + (json-read-array) + (should (eq pre 'pre)) + (should (eq post 'post))))) (ert-deftest test-json-encode-array () - (let ((json-encoding-pretty-print nil)) - (should (equal (json-encode-array [1 2 "a" "b"]) - "[1,2,\"a\",\"b\"]")))) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[1]")) + (should (equal (json-encode-array '[1]) "[1]")) + (should (equal (json-encode-array '(2 1)) "[2,1]")) + (should (equal (json-encode-array '[2 1]) "[2,1]")) + (should (equal (json-encode-array '[:b a 2 1]) "[\"b\",\"a\",2,1]")))) + +(ert-deftest test-json-encode-array-pretty () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings nil)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1\n]")) + (should (equal (json-encode-array '[1]) "[\n 1\n]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1\n]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1\n]")))) + +(ert-deftest test-json-encode-array-lisp-style () + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print t) + (json-encoding-default-indentation " ") + (json-encoding-lisp-style-closings t)) + (should (equal (json-encode-array ()) "[]")) + (should (equal (json-encode-array []) "[]")) + (should (equal (json-encode-array '(1)) "[\n 1]")) + (should (equal (json-encode-array '[1]) "[\n 1]")) + (should (equal (json-encode-array '(2 1)) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[2 1]) "[\n 2,\n 1]")) + (should (equal (json-encode-array '[:b a 2 1]) + "[\n \"b\",\n \"a\",\n 2,\n 1]")))) ;;; Reader (ert-deftest test-json-read () - (json-tests--with-temp-buffer "{ \"a\": 1 }" - ;; We don't care exactly what the return value is (that is tested - ;; in `test-json-read-object'), but it should parse without error. - (should (json-read))) + (pcase-dolist (`(,fn . ,contents) + '((json-read-string "\"\"" "\"a\"") + (json-read-array "[]" "[1]") + (json-read-object "{}" "{\"a\":1}") + (json-read-keyword "null" "false" "true") + (json-read-number + "-0" "0" "1" "2" "3" "4" "5" "6" "7" "8" "9"))) + (dolist (content contents) + ;; Check that leading whitespace is skipped. + (dolist (str (list content (concat " " content))) + (cl-letf* ((called nil) + ((symbol-function fn) + (lambda (&rest _) (setq called t)))) + (json-tests--with-temp-buffer str + ;; We don't care exactly what the return value is (that is + ;; tested elsewhere), but it should parse without error. + (should (json-read)) + (should called))))))) + +(ert-deftest test-json-read-invalid () (json-tests--with-temp-buffer "" (should-error (json-read) :type 'json-end-of-file)) - (json-tests--with-temp-buffer "xxx" - (let ((err (should-error (json-read) :type 'json-readtable-error))) - (should (equal (cdr err) '(?x)))))) + (json-tests--with-temp-buffer " " + (should-error (json-read) :type 'json-end-of-file)) + (json-tests--with-temp-buffer "x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x)))) + (json-tests--with-temp-buffer " x" + (should (equal (should-error (json-read)) + '(json-readtable-error ?x))))) (ert-deftest test-json-read-from-string () - (let ((json-string "{ \"a\": 1 }")) - (json-tests--with-temp-buffer json-string - (should (equal (json-read-from-string json-string) + (dolist (str '("\"\"" "\"a\"" "[]" "[1]" "{}" "{\"a\":1}" + "null" "false" "true" "0" "123")) + (json-tests--with-temp-buffer str + (should (equal (json-read-from-string str) (json-read)))))) -;;; JSON encoder +;;; Encoder (ert-deftest test-json-encode () + (should (equal (json-encode t) "true")) + (let ((json-null 'null)) + (should (equal (json-encode json-null) "null"))) + (let ((json-false 'false)) + (should (equal (json-encode json-false) "false"))) + (should (equal (json-encode "") "\"\"")) (should (equal (json-encode "foo") "\"foo\"")) + (should (equal (json-encode :) "\"\"")) + (should (equal (json-encode :foo) "\"foo\"")) + (should (equal (json-encode '(1)) "[1]")) + (should (equal (json-encode 'foo) "\"foo\"")) + (should (equal (json-encode 0) "0")) + (should (equal (json-encode 123) "123")) + (let ((json-encoding-object-sort-predicate nil) + (json-encoding-pretty-print nil)) + (should (equal (json-encode []) "[]")) + (should (equal (json-encode [1]) "[1]")) + (should (equal (json-encode #s(hash-table)) "{}")) + (should (equal (json-encode #s(hash-table data (a 1))) "{\"a\":1}"))) (with-temp-buffer - (should-error (json-encode (current-buffer)) :type 'json-error))) + (should (equal (should-error (json-encode (current-buffer))) + (list 'json-error (current-buffer)))))) -;;; Pretty-print +;;; Pretty printing & minimizing (defun json-tests-equal-pretty-print (original &optional expected) "Abort current test if pretty-printing ORIGINAL does not yield EXPECTED. @@ -351,46 +931,45 @@ nil, ORIGINAL should stay unchanged by pretty-printing." (json-tests-equal-pretty-print "0.123")) (ert-deftest test-json-pretty-print-object () - ;; empty (regression test for bug#24252) - (json-tests-equal-pretty-print - "{}" - "{\n}") - ;; one pair + ;; Empty (regression test for bug#24252). + (json-tests-equal-pretty-print "{}") + ;; One pair. (json-tests-equal-pretty-print "{\"key\":1}" "{\n \"key\": 1\n}") - ;; two pairs + ;; Two pairs. (json-tests-equal-pretty-print "{\"key1\":1,\"key2\":2}" "{\n \"key1\": 1,\n \"key2\": 2\n}") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "{\"foo\":{\"key\":1}}" "{\n \"foo\": {\n \"key\": 1\n }\n}") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "{\"key\":[1,2]}" "{\n \"key\": [\n 1,\n 2\n ]\n}")) (ert-deftest test-json-pretty-print-array () - ;; empty + ;; Empty. (json-tests-equal-pretty-print "[]") - ;; one item + ;; One item. (json-tests-equal-pretty-print "[1]" "[\n 1\n]") - ;; two items + ;; Two items. (json-tests-equal-pretty-print "[1,2]" "[\n 1,\n 2\n]") - ;; embedded object + ;; Nested object. (json-tests-equal-pretty-print "[{\"key\":1}]" "[\n {\n \"key\": 1\n }\n]") - ;; embedded array + ;; Nested array. (json-tests-equal-pretty-print "[[1,2]]" "[\n [\n 1,\n 2\n ]\n]")) (provide 'json-tests) + ;;; json-tests.el ends here diff --git a/test/lisp/mail/qp-tests.el b/test/lisp/mail/qp-tests.el new file mode 100644 index 00000000000..8d704499334 --- /dev/null +++ b/test/lisp/mail/qp-tests.el @@ -0,0 +1,74 @@ +;;; qp-tests.el --- Tests for qp.el -*- lexical-binding:t; coding:utf-8 -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'qp) + +;; Quote by Antoine de Saint-Exupéry, Citadelle (1948) +;; from https://en.wikipedia.org/wiki/Quoted-printable +(defvar qp-tests-quote-qp + (concat "J'interdis aux marchands de vanter trop leurs marchandises. Car ils se font =\n" + "vite p=C3=A9dagogues et t'enseignent comme but ce qui n'est par essence qu'=\n" + "un moyen, et te trompant ainsi sur la route =C3=A0 suivre les voil=C3=A0 bi=\n" + "ent=C3=B4t qui te d=C3=A9gradent, car si leur musique est vulgaire ils te f=\n" + "abriquent pour te la vendre une =C3=A2me vulgaire.")) +(defvar qp-tests-quote-utf8 + (concat "J'interdis aux marchands de vanter trop leurs marchandises. Car ils se font " + "vite pédagogues et t'enseignent comme but ce qui n'est par essence qu'" + "un moyen, et te trompant ainsi sur la route à suivre les voilà bi" + "entôt qui te dégradent, car si leur musique est vulgaire ils te f" + "abriquent pour te la vendre une âme vulgaire.")) + +(ert-deftest qp-test--quoted-printable-decode-region () + (with-temp-buffer + (insert qp-tests-quote-qp) + (encode-coding-region (point-min) (point-max) 'utf-8) + (quoted-printable-decode-region (point-min) (point-max) 'utf-8) + (should (equal (buffer-string) qp-tests-quote-utf8)))) + +(ert-deftest qp-test--quoted-printable-decode-string () + (should (equal (quoted-printable-decode-string "foo!") "foo!")) + (should (equal (quoted-printable-decode-string "=0C") "\^L")) + (should (equal (quoted-printable-decode-string "=3D") "=")) + (should (equal (quoted-printable-decode-string "=A1Hola, se=F1or!?") + "\241Hola, se\361or!?"))) + +(ert-deftest qp-test--quoted-printable-encode-region () + (with-temp-buffer + (insert (make-string 26 ?=)) + ;; (encode-coding-region (point-min) (point-max) 'utf-8) + (quoted-printable-encode-region (point-min) (point-max) t) + (should (equal (buffer-string) + (concat "=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D" + "=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=\n=3D"))))) + +(ert-deftest qp-test--quoted-printable-encode-string () + (should (equal (quoted-printable-encode-string "\241Hola, se\361or!?") + "=A1Hola, se=F1or!?")) + ;; Multibyte character. + (should-error (quoted-printable-encode-string "å"))) + +(provide 'qp-tests) +;;; qp-tests.el ends here diff --git a/test/lisp/mail/rfc2045-tests.el b/test/lisp/mail/rfc2045-tests.el new file mode 100644 index 00000000000..edd7a88c69e --- /dev/null +++ b/test/lisp/mail/rfc2045-tests.el @@ -0,0 +1,37 @@ +;;; rfc2045-tests.el --- Tests for rfc2045.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'rfc2045) + +(ert-deftest rfc2045-test-encode-string () + (should (equal (rfc2045-encode-string "foo" "bar") "foo=bar")) + (should (equal (rfc2045-encode-string "foo" "bar-baz") "foo=bar-baz")) + (should (equal (rfc2045-encode-string "foo" "bar baz") "foo=\"bar baz\"")) + (should (equal (rfc2045-encode-string "foo" "bar\tbaz") "foo=\"bar\tbaz\"")) + (should (equal (rfc2045-encode-string "foo" "bar\nbaz") "foo=\"bar\nbaz\""))) + +(provide 'rfc2045-tests) +;;; rfc2045-tests.el ends here diff --git a/test/lisp/mail/rfc2368-tests.el b/test/lisp/mail/rfc2368-tests.el new file mode 100644 index 00000000000..c35b8e33ad5 --- /dev/null +++ b/test/lisp/mail/rfc2368-tests.el @@ -0,0 +1,39 @@ +;;; rfc2368-tests.el --- Tests for rfc2368.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'rfc2368) + +(ert-deftest rfc2368-unhexify-string () + (should (equal (rfc2368-unhexify-string "hello%20there") "hello there"))) + +(ert-deftest rfc2368-parse-mailto-url () + (should (equal (rfc2368-parse-mailto-url "mailto:foo@example.org?subject=Foo&bar=baz") + '(("To" . "foo@example.org") ("Subject" . "Foo") ("Bar" . "baz")))) + (should (equal (rfc2368-parse-mailto-url "mailto:foo@bar.com?to=bar@example.org") + '(("To" . "foo@bar.com, bar@example.org")))) + (should (equal (rfc2368-parse-mailto-url "mailto:foo@bar.com?subject=bar%20baz") + '(("To" . "foo@bar.com") ("Subject" . "bar baz"))))) + +(provide 'rfc2368-tests) +;;; rfc2368-tests.el ends here diff --git a/test/lisp/man-tests.el b/test/lisp/man-tests.el index fba4d748ce1..8267d8e4f6a 100644 --- a/test/lisp/man-tests.el +++ b/test/lisp/man-tests.el @@ -1,4 +1,4 @@ -;;; man-tests.el --- Test suite for man. +;;; man-tests.el --- Test suite for man. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -114,7 +114,7 @@ in the cdr of the element.") (dolist (test man-tests-parse-man-k-tests) (should (man-tests-parse-man-k-test-case test)))) -(defun man-tests-filter-strings (buffer strings) +(defun man-tests-filter-strings (_buffer strings) "Run `Man-bgproc-filter' on each of STRINGS. The formatted result will be inserted into BUFFER." (let ((proc (start-process "dummy man-tests proc" (current-buffer) "cat"))) diff --git a/test/lisp/misc-tests.el b/test/lisp/misc-tests.el new file mode 100644 index 00000000000..fbcbfb7d0cc --- /dev/null +++ b/test/lisp/misc-tests.el @@ -0,0 +1,77 @@ +;;; misc-tests.el --- Tests for misc.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Stefan Kangas <stefankangas@gmail.com> + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(defmacro with-misc-test (original result &rest body) + (declare (indent 2)) + `(with-temp-buffer + (insert ,original) + ,@body + (should (equal (buffer-string) ,result)))) + +(ert-deftest misc-test-copy-from-above-command () + (with-misc-test "abc\n" "abc\nabc" + (copy-from-above-command)) + (with-misc-test "abc\n" "abc\nab" + (copy-from-above-command 2))) + +(ert-deftest misc-test-zap-up-to-char () + (with-misc-test "abcde" "cde" + (goto-char (point-min)) + (zap-up-to-char 1 ?c)) + (with-misc-test "abcde abc123" "c123" + (goto-char (point-min)) + (zap-up-to-char 2 ?c))) + +(ert-deftest misc-test-upcase-char () + (with-misc-test "abcde" "aBCDe" + (goto-char (1+ (point-min))) + (upcase-char 3))) + +(ert-deftest misc-test-forward-to-word () + (with-temp-buffer + (insert " - abc") + (goto-char (point-min)) + (forward-to-word 1) + (should (equal (point) 9))) + (with-temp-buffer + (insert "a b c") + (goto-char (point-min)) + (forward-to-word 3) + (should (equal (point) 6)))) + +(ert-deftest misc-test-backward-to-word () + (with-temp-buffer + (insert "abc - ") + (backward-to-word 1) + (should (equal (point) 4))) + (with-temp-buffer + (insert "a b c") + (backward-to-word 3) + (should (equal (point) 1)))) + +(provide 'misc-tests) +;;; misc-tests.el ends here diff --git a/test/lisp/net/dbus-tests.el b/test/lisp/net/dbus-tests.el index 68f69f62b56..45c98513653 100644 --- a/test/lisp/net/dbus-tests.el +++ b/test/lisp/net/dbus-tests.el @@ -1,4 +1,4 @@ -;;; dbus-tests.el --- Tests of D-Bus integration into Emacs +;;; dbus-tests.el --- Tests of D-Bus integration into Emacs -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -176,8 +176,8 @@ This includes initialization and closing the bus." (defun dbus-test-all (&optional interactive) "Run all tests for \\[dbus]." (interactive "p") - (funcall - (if interactive 'ert-run-tests-interactively 'ert-run-tests-batch) "^dbus")) + (funcall (if interactive #'ert-run-tests-interactively #'ert-run-tests-batch) + "^dbus")) (provide 'dbus-tests) ;;; dbus-tests.el ends here diff --git a/test/lisp/net/dig-tests.el b/test/lisp/net/dig-tests.el new file mode 100644 index 00000000000..1b14384634e --- /dev/null +++ b/test/lisp/net/dig-tests.el @@ -0,0 +1,56 @@ +;;; dig-tests.el --- Tests for dig.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'dig) + +(defvar dig-test-result-data " +; <<>> DiG 9.11.16-2-Debian <<>> gnu.org +;; global options: +cmd +;; Got answer: +;; ->>HEADER<<- opcode: QUERY, status: NOERROR, id: 7777 +;; flags: qr rd ra; QUERY: 1, ANSWER: 1, AUTHORITY: 0, ADDITIONAL: 1 + +;; OPT PSEUDOSECTION: +; EDNS: version: 0, flags:; udp: 4096 +;; QUESTION SECTION: +;gnu.org. IN A + +;; ANSWER SECTION: +gnu.org. 300 IN A 111.11.111.111 + +;; Query time: 127 msec +;; SERVER: 192.168.0.1#53(192.168.0.1) +;; WHEN: Sun Apr 26 00:47:55 CEST 2020 +;; MSG SIZE rcvd: 52 + +" "Data used to test dig.el.") + +(ert-deftest dig-test-dig-extract-rr () + (with-temp-buffer + (insert dig-test-result-data) + (should (equal (dig-extract-rr "gnu.org") + "gnu.org. 300 IN A 111.11.111.111")))) + +(provide 'dig-tests) +;;; dig-tests.el ends here diff --git a/test/lisp/net/gnutls-tests.el b/test/lisp/net/gnutls-tests.el index c2472d844c1..07e30b64642 100644 --- a/test/lisp/net/gnutls-tests.el +++ b/test/lisp/net/gnutls-tests.el @@ -1,4 +1,4 @@ -;;; gnutls-tests.el --- Test suite for gnutls.el +;;; gnutls-tests.el --- Test suite for gnutls.el -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/hmac-md5-tests.el b/test/lisp/net/hmac-md5-tests.el new file mode 100644 index 00000000000..30d221ec87b --- /dev/null +++ b/test/lisp/net/hmac-md5-tests.el @@ -0,0 +1,80 @@ +;;; hmac-md5-tests.el --- Tests for hmac-md5.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'hmac-md5) + +;; Test cases from RFC 2202, "Test Cases for HMAC-MD5 and HMAC-SHA-1", +;; moved here from hmac-md5.el + +(ert-deftest hmac-md5-test-encode-string () + ;; RFC 2202 -- test_case 1 + (should (equal (encode-hex-string + (hmac-md5 "Hi There" (make-string 16 ?\x0b))) + "9294727a3638bb1c13f48ef8158bfc9d")) + + ;; RFC 2202 -- test_case 2 + (should (equal (encode-hex-string + (hmac-md5 "what do ya want for nothing?" "Jefe")) + "750c783e6ab0b503eaa86e310a5db738")) + + ;; RFC 2202 -- test_case 3 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string (make-string 100 ?d)) + (decode-hex-string (make-string 32 ?a)))) + "56be34521d144c88dbb8c733f0e8b3f6")) + + ;; RFC 2202 -- test_case 4 + (should (equal (encode-hex-string + (hmac-md5 (decode-hex-string + (mapconcat (lambda (c) (concat (list c) "d")) + (make-string 50 ?c) "")) + (decode-hex-string "0102030405060708090a0b0c0d0e0f10111213141516171819"))) + "697eaf0aca3a3aea3a75164746ffaa79")) + + ;; RFC 2202 -- test_case 5 (a) + (should (equal (encode-hex-string + (hmac-md5 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995690efd4c")) + + ;; RFC 2202 -- test_case 5 (b) + (should (equal (encode-hex-string + (hmac-md5-96 "Test With Truncation" (make-string 16 ?\x0c))) + "56461ef2342edc00f9bab995")) + + ;; RFC 2202 -- test_case 6 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key - Hash Key First" + (decode-hex-string (make-string 160 ?a)))) + "6b1ab7fe4bd7bf8f0b62e6ce61b9d0cd")) + + ;; RFC 2202 -- test_case 7 + (should (equal (encode-hex-string + (hmac-md5 + "Test Using Larger Than Block-Size Key and Larger Than One Block-Size Data" + (decode-hex-string (make-string 160 ?a)))) + "6f630fad67cda0ee1fb1f562db3aa53e"))) + +(provide 'hmac-md5-tests) +;;; hmac-md5-tests.el ends here diff --git a/test/lisp/net/network-stream-tests.el b/test/lisp/net/network-stream-tests.el index 28686547a44..7a982548ae1 100644 --- a/test/lisp/net/network-stream-tests.el +++ b/test/lisp/net/network-stream-tests.el @@ -724,4 +724,56 @@ 44777 (vector :nowait t)))) +(ert-deftest check-network-process-coding-system-bind () + "Check that binding coding-system-for-{read,write} works." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-no-override () + "Check that coding-system-for-{read,write} is not overridden by :coding nil." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding nil + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'binary)) + (should (eq (cdr coding) 'utf-8-unix)) + (delete-process server))) + +(ert-deftest check-network-process-coding-system-override () + "Check that :coding non-nil overrides coding-system-for-{read,write}." + (let* ((coding-system-for-read 'binary) + (coding-system-for-write 'utf-8-unix) + (server + (make-network-process + :name "server" + :server t + :noquery t + :family 'ipv4 + :service t + :coding 'georgian-academy + :host 'local)) + (coding (process-coding-system server))) + (should (eq (car coding) 'georgian-academy)) + (should (eq (cdr coding) 'georgian-academy)) + (delete-process server))) ;;; network-stream-tests.el ends here diff --git a/test/lisp/net/newsticker-tests.el b/test/lisp/net/newsticker-tests.el index 1a6e11dc512..5552fa8c1a6 100644 --- a/test/lisp/net/newsticker-tests.el +++ b/test/lisp/net/newsticker-tests.el @@ -1,4 +1,4 @@ -;;; newsticker-testsuite.el --- Test suite for newsticker. +;;; newsticker-tests.el --- Test suite for newsticker. -*- lexical-binding:t -*- ;; Copyright (C) 2003-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/puny-tests.el b/test/lisp/net/puny-tests.el index 9fb2ebb5469..7dac39795b6 100644 --- a/test/lisp/net/puny-tests.el +++ b/test/lisp/net/puny-tests.el @@ -1,4 +1,4 @@ -;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; -*- +;;; puny-tests.el --- tests for net/puny.el -*- coding: utf-8; lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. @@ -38,4 +38,25 @@ "Test puny decoding." (should (string= (puny-decode-string "xn--9dbdkw") "חנוך"))) +(ert-deftest puny-test-encode-domain () + (should (string= (puny-encode-domain "åäö.se") "xn--4cab6c.se"))) + +(ert-deftest puny-test-decode-domain () + (should (string= (puny-decode-domain "xn--4cab6c.se") "åäö.se"))) + +(ert-deftest puny-highly-restrictive-domain-p () + (should (puny-highly-restrictive-domain-p "foo.bar.org")) + (should (puny-highly-restrictive-domain-p "foo.abcåäö.org")) + (should (puny-highly-restrictive-domain-p "foo.ர.org")) + ;; Disallow unicode character 2044, visually similar to "/". + (should-not (puny-highly-restrictive-domain-p "www.yourbank.com⁄login⁄checkUser.jsp?inxs.ch")) + ;; Disallow mixing scripts. + (should-not (puny-highly-restrictive-domain-p "åர.org")) + ;; Only allowed in moderately restrictive. + (should-not (puny-highly-restrictive-domain-p "Teχ.org")) + (should-not (puny-highly-restrictive-domain-p "HλLF-LIFE.org")) + (should-not (puny-highly-restrictive-domain-p "Ωmega.org")) + ;; Only allowed in unrestricted. + (should-not (puny-highly-restrictive-domain-p "I♥NY.org"))) + ;;; puny-tests.el ends here diff --git a/test/lisp/net/rfc2104-tests.el b/test/lisp/net/rfc2104-tests.el index 5c1f4410934..90535898382 100644 --- a/test/lisp/net/rfc2104-tests.el +++ b/test/lisp/net/rfc2104-tests.el @@ -1,4 +1,4 @@ -;;; rfc2104-tests.el --- Tests of RFC2104 hashes +;;; rfc2104-tests.el --- Tests of RFC2104 hashes -*- lexical-binding:t -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. diff --git a/test/lisp/net/sasl-scram-rfc-tests.el b/test/lisp/net/sasl-scram-rfc-tests.el index ec283c86f55..09e05b62a25 100644 --- a/test/lisp/net/sasl-scram-rfc-tests.el +++ b/test/lisp/net/sasl-scram-rfc-tests.el @@ -1,4 +1,4 @@ -;;; sasl-scram-rfc-tests.el --- tests for SCRAM-SHA-1 -*- lexical-binding: t; -*- +;;; sasl-scram-rfc-tests.el --- tests for SCRAM -*- lexical-binding: t; -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -19,7 +19,7 @@ ;;; Commentary: -;; Test cases from RFC 5802. +;; Test cases from RFC 5802 and RFC 7677. ;;; Code: @@ -47,4 +47,26 @@ (sasl-scram-sha-1-authenticate-server client (vector nil "v=rmF9pqV8S7suAoZWja4dJRkFsKQ= ")))) +(require 'sasl-scram-sha256) + +(ert-deftest sasl-scram-sha-256-test () + ;; The following strings are taken from section 3 of RFC 7677. + (let ((client + (sasl-make-client (sasl-find-mechanism '("SCRAM-SHA-256")) + "user" + "imap" + "localhost")) + (data "r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,s=W22ZaJ0SNY7soEsUEjb6gQ==,i=4096") + (c-nonce "rOprNGfwEbeRWgbNEkqO") + (sasl-read-passphrase + (lambda (_prompt) (copy-sequence "pencil")))) + (sasl-client-set-property client 'c-nonce c-nonce) + (should + (equal + (sasl-scram-sha-256-client-final-message client (vector nil data)) + "c=biws,r=rOprNGfwEbeRWgbNEkqO%hvYDpWUa2RaTCAfuxFIlj)hNlF$k0,p=dHzbZapWIk4jUhN+Ute9ytag9zjfMHgsqmmiz7AndVQ=")) + + ;; This should not throw an error: + (sasl-scram-sha-256-authenticate-server client (vector nil "v=6rriTRBi23WpRR/wtup+mMhUZUn/dB5nLTJRsjl95G4=")))) + ;;; sasl-scram-rfc-tests.el ends here diff --git a/test/lisp/net/tramp-archive-tests.el b/test/lisp/net/tramp-archive-tests.el index 95e41a3f03b..8c75d91bb58 100644 --- a/test/lisp/net/tramp-archive-tests.el +++ b/test/lisp/net/tramp-archive-tests.el @@ -60,7 +60,6 @@ (setq password-cache-expiry nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -971,4 +970,5 @@ If INTERACTIVE is non-nil, the tests are run interactively." "^tramp-archive")) (provide 'tramp-archive-tests) + ;;; tramp-archive-tests.el ends here diff --git a/test/lisp/net/tramp-tests.el b/test/lisp/net/tramp-tests.el index 544bdb5c058..34782e7f151 100644 --- a/test/lisp/net/tramp-tests.el +++ b/test/lisp/net/tramp-tests.el @@ -43,6 +43,7 @@ (require 'dired) (require 'ert) (require 'ert-x) +(require 'trace) (require 'tramp) (require 'vc) (require 'vc-bzr) @@ -50,6 +51,8 @@ (require 'vc-hg) (declare-function tramp-find-executable "tramp-sh") +(declare-function tramp-get-remote-chmod-h "tramp-sh") +(declare-function tramp-get-remote-gid "tramp-sh") (declare-function tramp-get-remote-path "tramp-sh") (declare-function tramp-get-remote-perl "tramp-sh") (declare-function tramp-get-remote-stat "tramp-sh") @@ -67,13 +70,14 @@ (defvar tramp-remote-path) (defvar tramp-remote-process-environment) -;; Needed for Emacs 24. -(defvar inhibit-message) ;; Needed for Emacs 25. (defvar connection-local-criteria-alist) (defvar connection-local-profile-alist) ;; Needed for Emacs 26. (defvar async-shell-command-width) +;; Needed for Emacs 27. +(defvar process-file-return-signal-string) +(defvar shell-command-dont-erase-buffer) ;; Beautify batch mode. (when noninteractive @@ -100,19 +104,22 @@ (add-to-list 'tramp-default-host-alist `("\\`mock\\'" nil ,(system-name))) - ;; Emacs' Makefile sets $HOME to a nonexistent value. Needed in - ;; batch mode only, therefore. + ;; Emacs's Makefile sets $HOME to a nonexistent value. Needed + ;; in batch mode only, therefore. (unless (and (null noninteractive) (file-directory-p "~/")) (setenv "HOME" temporary-file-directory)) (format "/mock::%s" temporary-file-directory))) "Temporary directory for Tramp tests.") +(defconst tramp-test-vec + (tramp-dissect-file-name tramp-test-temporary-file-directory) + "The used `tramp-file-name' structure.") + (setq auth-source-save-behavior nil password-cache-expiry nil remote-file-name-inhibit-cache nil tramp-cache-read-persistent-data t ;; For auth-sources. tramp-copy-size-limit nil - tramp-message-show-message nil tramp-persistency-file-name nil tramp-verbose 0) @@ -140,9 +147,7 @@ being the result.") (when (cdr tramp--test-enabled-checked) ;; Cleanup connection. (ignore-errors - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - nil 'keep-password))) + (tramp-cleanup-connection tramp-test-vec nil 'keep-password))) ;; Return result. (cdr tramp--test-enabled-checked)) @@ -173,38 +178,46 @@ This shall used dynamically bound only.") (defmacro tramp--test-instrument-test-case (verbose &rest body) "Run BODY with `tramp-verbose' equal VERBOSE. Print the content of the Tramp connection and debug buffers, if -`tramp-verbose' is greater than 3. `should-error' is not handled -properly. BODY shall not contain a timeout." +`tramp-verbose' is greater than 3. Print traces if `tramp-verbose' +is greater than 10. +`should-error' is not handled properly. BODY shall not contain a timeout." (declare (indent 1) (debug (natnump body))) - `(let ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) - (tramp-message-show-message t) - (debug-ignored-errors - (append - '("^make-symbolic-link not supported$" - "^error with add-name-to-file") - debug-ignored-errors)) - inhibit-message) + `(let* ((tramp-verbose (max (or ,verbose 0) (or tramp-verbose 0))) + (trace-buffer + (when (> tramp-verbose 10) (generate-new-buffer " *temp*"))) + (debug-ignored-errors + (append + '("^make-symbolic-link not supported$" + "^error with add-name-to-file") + debug-ignored-errors)) + inhibit-message) + (when trace-buffer + (dolist (elt (all-completions "tramp-" obarray 'functionp)) + (trace-function-background (intern elt)))) (unwind-protect (let ((tramp--test-instrument-test-case-p t)) ,@body) ;; Unwind forms. + (when trace-buffer + (untrace-all)) (when (and (null tramp--test-instrument-test-case-p) (> tramp-verbose 3)) - (dolist (buf (tramp-list-tramp-buffers)) + (dolist + (buf (if trace-buffer + (cons (get-buffer trace-buffer) (tramp-list-tramp-buffers)) + (tramp-list-tramp-buffers))) (with-current-buffer buf - (message ";; %s\n%s" buf (buffer-string)))))))) + (message ";; %s\n%s" buf (buffer-string))))) + (when trace-buffer + (kill-buffer trace-buffer))))) (defsubst tramp--test-message (fmt-string &rest arguments) "Emit a message into ERT *Messages*." (tramp--test-instrument-test-case 0 - (apply - #'tramp-message - (tramp-dissect-file-name tramp-test-temporary-file-directory) 0 - fmt-string arguments))) + (apply #'tramp-message tramp-test-vec 0 fmt-string arguments))) (defsubst tramp--test-backtrace () "Dump a backtrace into ERT *Messages*." (tramp--test-instrument-test-case 10 - (tramp-backtrace - (tramp-dissect-file-name tramp-test-temporary-file-directory)))) + (tramp-backtrace tramp-test-vec))) (defmacro tramp--test-print-duration (message &rest body) "Run BODY and print a message with duration, prompted by MESSAGE." @@ -1966,9 +1979,9 @@ properly. BODY shall not contain a timeout." ;; Host names must match rules in case the command template of a ;; method doesn't use them. (dolist (m '("su" "sg" "sudo" "doas" "ksu")) - (let ((vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) - tramp-connection-properties tramp-default-proxies-alist) - (ignore-errors (tramp-cleanup-connection vec nil 'keep-password)) + (let (tramp-connection-properties tramp-default-proxies-alist) + (ignore-errors + (tramp-cleanup-connection tramp-test-vec nil 'keep-password)) ;; Single hop. The host name must match `tramp-local-host-regexp'. (should-error (find-file (format "/%s:foo:" m)) @@ -1997,7 +2010,7 @@ properly. BODY shall not contain a timeout." ;; Samba does not support file names with periods followed by ;; spaces, and trailing periods or spaces. - (when (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (when (tramp--test-smb-p) (dolist (file '("foo." "foo. bar" "foo ")) (should-error (tramp-smb-get-localname @@ -2039,7 +2052,7 @@ properly. BODY shall not contain a timeout." "/method:host:/:/path//foo")) ;; Forwhatever reasons, the following tests let Emacs crash for - ;; Emacs 24 and Emacs 25, occasionally. No idea what's up. + ;; Emacs 25, occasionally. No idea what's up. (when (tramp--test-emacs26-p) (should (string-equal (substitute-in-file-name "/method:host://~foo") "/~foo")) @@ -2151,7 +2164,7 @@ properly. BODY shall not contain a timeout." ;; These are the methods the test doesn't fail. (when (or (tramp--test-adb-p) (tramp--test-ange-ftp-p) (tramp--test-gvfs-p) (tramp--test-rclone-p) - (tramp-smb-file-name-p tramp-test-temporary-file-directory)) + (tramp--test-smb-p)) (setf (ert-test-expected-result-type (ert-get-test 'tramp-test05-expand-file-name-relative)) :passed)) @@ -2218,11 +2231,10 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Bug#10085. (when (tramp--test-enabled) ;; Packages like tramp-gvfs.el might be disabled. - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) ;; We must clear `tramp-default-method'. On hydra, it is "ftp", ;; which ruins the tests. - (let ((non-essential n-e) - (tramp-default-method + (let ((tramp-default-method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host))) (dolist @@ -2238,7 +2250,7 @@ This checks also `file-name-as-directory', `file-name-directory', (should (string-equal (file-name-as-directory file) - (if (tramp-completion-mode-p) + (if non-essential file (concat file (if (tramp--test-ange-ftp-p) "/" "./"))))) (should (string-equal (file-name-directory file) file)) (should (string-equal (file-name-nondirectory file) ""))))))) @@ -2296,16 +2308,25 @@ This checks also `file-name-as-directory', `file-name-directory', (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foo")) - (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foofoo")) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) + (goto-char (1+ (point))) + (let ((point (point))) + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "ffoooo")) + (should (= point (point)))) ;; Insert partly. - (insert-file-contents tmp-name nil 1 3) - (should (string-equal (buffer-string) "oofoofoo")) + (let ((point (point))) + (insert-file-contents tmp-name nil 1 3) + (should (string-equal (buffer-string) "foofoooo")) + (should (= point (point)))) ;; Replace. - (insert-file-contents tmp-name nil nil nil 'replace) - (should (string-equal (buffer-string) "foo")) + (let ((point (point))) + (insert-file-contents tmp-name nil nil nil 'replace) + (should (string-equal (buffer-string) "foo")) + (should (= point (point)))) ;; Error case. (delete-file tmp-name) (should-error @@ -2357,7 +2378,14 @@ This checks also `file-name-as-directory', `file-name-directory', (write-region nil nil tmp-name 3)) (with-temp-buffer (insert-file-contents tmp-name) - (should (string-equal (buffer-string) "foobaz")))) + (should (string-equal (buffer-string) "foobaz"))) + (delete-file tmp-name) + (with-temp-buffer + (insert "foo") + (write-region nil nil tmp-name 'append)) + (with-temp-buffer + (insert-file-contents tmp-name) + (should (string-equal (buffer-string) "foo")))) ;; Write string. (write-region "foo" nil tmp-name) @@ -2376,7 +2404,7 @@ This checks also `file-name-as-directory', `file-name-directory', ;; Check message. ;; Macro `ert-with-message-capture' was introduced in Emacs 26.1. (with-no-warnings (when (symbol-plist 'ert-with-message-capture) - (let ((tramp-message-show-message t)) + (let (inhibit-message) (dolist (noninteractive (unless (tramp--test-ange-ftp-p) '(nil t))) (dolist (visit '(nil t "string" no-message)) @@ -2393,14 +2421,14 @@ This checks also `file-name-as-directory', `file-name-directory', tramp--test-messages)))))))) ;; Do not overwrite if excluded. - (cl-letf (((symbol-function 'y-or-n-p) (lambda (_prompt) t)) + (cl-letf (((symbol-function #'y-or-n-p) (lambda (_prompt) t)) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) ;; `mustbenew' is passed to Tramp since Emacs 26.1. (when (tramp--test-emacs26-p) (should-error - (cl-letf (((symbol-function 'y-or-n-p) 'ignore) + (cl-letf (((symbol-function #'y-or-n-p) #'ignore) ;; Ange-FTP. ((symbol-function 'yes-or-no-p) 'ignore)) (write-region "foo" nil tmp-name nil nil nil 'mustbenew)) @@ -2911,6 +2939,9 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." ;; (this is performed by `dired'). If FULL is nil, it shows just ;; one file. So we refrain from testing. (skip-unless (not (tramp--test-ange-ftp-p))) + ;; `insert-directory' of crypted remote directories works only since + ;; Emacs 27.1. + (skip-unless (or (not (tramp--test-crypt-p)) (tramp--test-emacs27-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name1 @@ -2981,6 +3012,8 @@ This tests also `file-directory-p' and `file-accessible-directory-p'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) (skip-unless (not (tramp--test-rsync-p))) + ;; Wildcards are not supported in tramp-crypt.el. + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (fboundp 'insert-directory-wildcard-in-dir-p)) @@ -3115,22 +3148,37 @@ This tests also `access-file', `file-readable-p', (file-remote-p tmp-name1) (replace-regexp-in-string "/" "//" (file-remote-p tmp-name1 'localname)))) + ;; `file-ownership-preserved-p' is implemented only in tramp-sh.el. + (test-file-ownership-preserved-p (tramp--test-sh-p)) attr) (unwind-protect (progn + ;; A sticky bit could damage the `file-ownership-preserved-p' test. + (when + (and test-file-ownership-preserved-p + (zerop (logand + #o1000 + (file-modes tramp-test-temporary-file-directory)))) + (write-region "foo" nil tmp-name1) + (setq test-file-ownership-preserved-p + (= (tramp-compat-file-attribute-group-id + (file-attributes tmp-name1)) + (tramp-get-remote-gid tramp-test-vec 'integer))) + (delete-file tmp-name1)) + (should-error (access-file tmp-name1 "error") :type tramp-file-missing) ;; `file-ownership-preserved-p' should return t for - ;; non-existing files. It is implemented only in tramp-sh.el. - (when (tramp--test-sh-p) + ;; non-existing files. + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (write-region "foo" nil tmp-name1) (should (file-exists-p tmp-name1)) (should (file-readable-p tmp-name1)) (should (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) ;; We do not test inodes and device numbers. @@ -3160,16 +3208,16 @@ This tests also `access-file', `file-readable-p', (should (stringp (tramp-compat-file-attribute-group-id attr))) (tramp--test-ignore-make-symbolic-link-error - (should-error - (access-file tmp-name2 "error") - :type tramp-file-missing) - (when (tramp--test-sh-p) + (should-error + (access-file tmp-name2 "error") + :type tramp-file-missing) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (make-symbolic-link tmp-name1 tmp-name2) (should (file-exists-p tmp-name2)) (should (file-symlink-p tmp-name2)) (should-not (access-file tmp-name2 "error")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name2 'group))) (setq attr (file-attributes tmp-name2)) (should @@ -3200,7 +3248,7 @@ This tests also `access-file', `file-readable-p', (tramp-dissect-file-name tmp-name3)))) (delete-file tmp-name2)) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (delete-file tmp-name1) (make-directory tmp-name1) @@ -3208,7 +3256,7 @@ This tests also `access-file', `file-readable-p', (should (file-readable-p tmp-name1)) (should-not (file-regular-p tmp-name1)) (should-not (access-file tmp-name1 "")) - (when (tramp--test-sh-p) + (when test-file-ownership-preserved-p (should (file-ownership-preserved-p tmp-name1 'group))) (setq attr (file-attributes tmp-name1)) (should (eq (tramp-compat-file-attribute-type attr) t))) @@ -3350,25 +3398,80 @@ This tests also `file-executable-p', `file-writable-p' and `set-file-modes'." "ftp" (file-remote-p tramp-test-temporary-file-directory 'method))))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name nil quoted))) + (unwind-protect (progn - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (set-file-modes tmp-name #o777) - (should (= (file-modes tmp-name) #o777)) - (should (file-executable-p tmp-name)) - (should (file-writable-p tmp-name)) - (set-file-modes tmp-name #o444) - (should (= (file-modes tmp-name) #o444)) - (should-not (file-executable-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (set-file-modes tmp-name1 #o777) + (should (= (file-modes tmp-name1) #o777)) + (should (file-executable-p tmp-name1)) + (should (file-writable-p tmp-name1)) + (set-file-modes tmp-name1 #o444) + (should (= (file-modes tmp-name1) #o444)) + (should-not (file-executable-p tmp-name1)) ;; A file is always writable for user "root". (unless (zerop (tramp-compat-file-attribute-user-id - (file-attributes tmp-name))) - (should-not (file-writable-p tmp-name)))) + (file-attributes tmp-name1))) + (should-not (file-writable-p tmp-name1))) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-modes tmp-name1 #o222 'nofollow) + (should (= (file-modes tmp-name1 'nofollow) #o222))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name)))))) + (ignore-errors (delete-file tmp-name1))) + + ;; Check the NOFOLLOW arg. It exists since Emacs 28. It is + ;; implemented for tramp-gvfs.el and tramp-sh.el. However, + ;; tramp-gvfs,el does not support creating symbolic links. And + ;; in tramp-sh.el, we must ensure that the remote chmod command + ;; supports the "-h" argument. + (when (and (tramp--test-emacs28-p) (tramp--test-sh-p) + (tramp-get-remote-chmod-h tramp-test-vec)) + (unwind-protect + (with-no-warnings + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) + (make-symbolic-link tmp-name1 tmp-name2) + (should + (string-equal + (funcall + (if quoted #'tramp-compat-file-name-unquote #'identity) + (file-remote-p tmp-name1 'localname)) + (file-symlink-p tmp-name2))) + ;; Both report the modes of `tmp-name1'. + (should + (= (file-modes tmp-name1) (file-modes tmp-name2))) + ;; `tmp-name1' is a regular file. NOFOLLOW doesn't matter. + (should + (= (file-modes tmp-name1) (file-modes tmp-name1 'nofollow))) + ;; `tmp-name2' is a symbolic link. It has different permissions. + (should-not + (= (file-modes tmp-name2) (file-modes tmp-name2 'nofollow))) + (should-not + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + ;; Change permissions. + (set-file-modes tmp-name1 #o200) + (set-file-modes tmp-name2 #o200) + (should + (= (file-modes tmp-name1) (file-modes tmp-name2) #o200)) + ;; Change permissions with NOFOLLOW. + (set-file-modes tmp-name1 #o300 'nofollow) + (set-file-modes tmp-name2 #o300 'nofollow) + (should + (= (file-modes tmp-name1 'nofollow) + (file-modes tmp-name2 'nofollow))) + (should-not (= (file-modes tmp-name1) (file-modes tmp-name2)))) + + ;; Cleanup. + (ignore-errors (delete-file tmp-name1)) + (ignore-errors (delete-file tmp-name2))))))) ;; Method "smb" could run into "NT_STATUS_REVISION_MISMATCH" error. (defmacro tramp--test-ignore-add-name-to-file-error (&rest body) @@ -3420,11 +3523,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :type 'file-already-exists)) (when (tramp--test-expensive-test) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (make-symbolic-link tmp-name1 tmp-name2 0) :type 'file-already-exists))) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (make-symbolic-link tmp-name1 tmp-name2 0) (should (string-equal @@ -3496,11 +3599,11 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (add-name-to-file tmp-name1 tmp-name2) :type 'file-already-exists) ;; A number means interactive case. - (cl-letf (((symbol-function 'yes-or-no-p) #'ignore)) + (cl-letf (((symbol-function #'yes-or-no-p) #'ignore)) (should-error (add-name-to-file tmp-name1 tmp-name2 0) :type 'file-already-exists)) - (cl-letf (((symbol-function 'yes-or-no-p) (lambda (_prompt) t))) + (cl-letf (((symbol-function #'yes-or-no-p) (lambda (_prompt) t))) (add-name-to-file tmp-name1 tmp-name2 0) (should (file-regular-p tmp-name2))) (add-name-to-file tmp-name1 tmp-name2 'ok-if-already-exists) @@ -3627,7 +3730,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp--test-ignore-make-symbolic-link-error (make-symbolic-link tmp-name2 tmp-name1) (should (file-symlink-p tmp-name1)) - (if (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (if (tramp--test-smb-p) ;; The symlink command of `smbclient' detects the ;; cycle already. (should-error @@ -3690,7 +3793,17 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (file-newer-than-file-p tmp-name2 tmp-name1)) ;; `tmp-name3' does not exist. (should (file-newer-than-file-p tmp-name2 tmp-name3)) - (should-not (file-newer-than-file-p tmp-name3 tmp-name1)))) + (should-not (file-newer-than-file-p tmp-name3 tmp-name1)) + ;; Check the NOFOLLOW arg. It exists since Emacs 28. For + ;; regular files, there shouldn't be a difference. + (when (tramp--test-emacs28-p) + (with-no-warnings + (set-file-times tmp-name1 (seconds-to-time 1) 'nofollow) + (should + (tramp-compat-time-equal-p + (tramp-compat-file-attribute-modification-time + (file-attributes tmp-name1)) + (seconds-to-time 1))))))) ;; Cleanup. (ignore-errors @@ -3730,6 +3843,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check that `file-acl' and `set-file-acl' work proper." (skip-unless (tramp--test-enabled)) (skip-unless (file-acl tramp-test-temporary-file-directory)) + (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) @@ -3808,6 +3922,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (skip-unless (not (equal (file-selinux-context tramp-test-temporary-file-directory) '(nil nil nil nil)))) + (skip-unless (not (tramp--test-crypt-p))) ;; `filename-non-special' has been fixed in Emacs 27.1, see Bug#29579. (dolist (quoted (if (and (tramp--test-expensive-test) (tramp--test-emacs27-p)) @@ -3951,7 +4066,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (when (not (memq system-type '(cygwin windows-nt))) (let ((method (file-remote-p tramp-test-temporary-file-directory 'method)) (host (file-remote-p tramp-test-temporary-file-directory 'host)) - (vec (tramp-dissect-file-name tramp-test-temporary-file-directory)) (orig-syntax tramp-syntax)) (when (and (stringp host) (string-match tramp-host-with-port-regexp host)) (setq host (match-string 1 host))) @@ -3964,7 +4078,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (tramp-change-syntax syntax) ;; This has cleaned up all connection data, which are used ;; for completion. We must refill the cache. - (tramp-set-connection-property vec "property" nil) + (tramp-set-connection-property tramp-test-vec "property" nil) (let ;; This is needed for the `simplified' syntax. ((method-marker @@ -4020,10 +4134,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (tramp-change-syntax orig-syntax)))) - (dolist (n-e '(nil t)) + (dolist (non-essential '(nil t)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) - (let ((non-essential n-e) - (tmp-name (tramp--test-make-temp-name nil quoted))) + (let ((tmp-name (tramp--test-make-temp-name nil quoted))) (unwind-protect (progn @@ -4113,6 +4226,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let* ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4126,6 +4240,28 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (zerop (process-file "true"))) (should-not (zerop (process-file "false"))) (should-not (zerop (process-file "binary-does-not-exist"))) + ;; Return exit code. + (should (= 42 (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "exit 42"))) + ;; Return exit code in case the process is interrupted, + ;; and there's no indication for a signal describing string. + (let (process-file-return-signal-string) + (should + (= (+ 128 2) + (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "kill -2 $$")))) + ;; Return string in case the process is interrupted and + ;; there's an indication for a signal describing string. + (let ((process-file-return-signal-string t)) + (should + (string-equal + "Interrupt" + (process-file + (if (tramp--test-adb-p) "/system/bin/sh" "/bin/sh") + nil nil nil "-c" "kill -2 $$")))) + (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) @@ -4169,6 +4305,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) @@ -4181,7 +4318,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (setq proc (start-file-process "test1" (current-buffer) "cat")) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4224,7 +4361,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (set-process-filter proc (lambda (p s) (with-current-buffer (process-buffer p) (insert s)))) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4242,13 +4379,14 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) - ;; `make-process' has been inserted in Emacs 25.1. It supports file - ;; name handlers since Emacs 27. + (skip-unless (not (tramp--test-crypt-p))) + ;; `make-process' supports file name handlers since Emacs 27. (skip-unless (tramp--test-emacs27-p)) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((default-directory tramp-test-temporary-file-directory) - (tmp-name (tramp--test-make-temp-name nil quoted)) + (tmp-name1 (tramp--test-make-temp-name nil quoted)) + (tmp-name2 (tramp--test-make-temp-name 'local quoted)) kill-buffer-query-functions proc) (with-no-warnings (should-not (make-process))) @@ -4262,7 +4400,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4278,13 +4416,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Simple process using a file. (unwind-protect (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) + (write-region "foo" nil tmp-name1) + (should (file-exists-p tmp-name1)) (setq proc (with-no-warnings (make-process :name "test2" :buffer (current-buffer) - :command `("cat" ,(file-name-nondirectory tmp-name)) + :command `("cat" ,(file-name-nondirectory tmp-name1)) :file-handler t))) (should (processp proc)) ;; Read output. @@ -4296,7 +4434,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc) - (delete-file tmp-name))) + (delete-file tmp-name1))) ;; Process filter. (unwind-protect @@ -4311,7 +4449,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) ;; Read output. (with-timeout (10 (tramp--test-timeout-handler)) @@ -4337,7 +4475,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :file-handler t))) (should (processp proc)) (should (equal (process-status proc) 'run)) - (process-send-string proc "foo") + (process-send-string proc "foo\n") (process-send-eof proc) (delete-process proc) ;; Read output. @@ -4345,42 +4483,74 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (while (accept-process-output proc 0 nil t))) ;; We cannot use `string-equal', because tramp-adb.el ;; echoes also the sent string. And a remote macOS sends - ;; a slightly modified string. - (should (string-match "killed.*\n\\'" (buffer-string)))) + ;; a slightly modified string. On MS Windows, + ;; `delete-process' sends an unknown signal. + (should + (string-match + (if (eq system-type 'windows-nt) + "unknown signal\n\\'" "killed.*\n\\'") + (buffer-string)))) ;; Cleanup. (ignore-errors (delete-process proc))) - ;; Process with stderr. tramp-adb.el doesn't support it (yet). - (unless (tramp--test-adb-p) - (let ((stderr (generate-new-buffer "*stderr*"))) - (unwind-protect + ;; Process with stderr buffer. + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test5" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr stderr + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc 0 nil t))) + (delete-process proc) + (with-current-buffer stderr + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (kill-buffer stderr)))) + + ;; Process with stderr file. + (dolist (tmpfile `(,tmp-name1 ,tmp-name2)) + (unwind-protect + (with-temp-buffer + (setq proc + (with-no-warnings + (make-process + :name "test6" :buffer (current-buffer) + :command '("cat" "/does-not-exist") + :stderr tmpfile + :file-handler t))) + (should (processp proc)) + ;; Read stderr. + (with-timeout (10 (tramp--test-timeout-handler)) + (while (accept-process-output proc nil nil t))) + (delete-process proc) (with-temp-buffer - (setq proc - (with-no-warnings - (make-process - :name "test5" :buffer (current-buffer) - :command '("cat" "/") - :stderr stderr - :file-handler t))) - (should (processp proc)) - ;; Read stderr. - (with-current-buffer stderr - (with-timeout (10 (tramp--test-timeout-handler)) - (while (= (point-min) (point-max)) - (while (accept-process-output proc 0 nil t)))) - (should - (string-match "^cat:.* Is a directory" (buffer-string))))) + (insert-file-contents tmpfile) + (should + (string-match + "cat:.* No such file or directory" (buffer-string))))) - ;; Cleanup. - (ignore-errors (delete-process proc)) - (ignore-errors (kill-buffer stderr)))))))) + ;; Cleanup. + (ignore-errors (delete-process proc)) + (ignore-errors (delete-file tmpfile))))))) (ert-deftest tramp-test31-interrupt-process () "Check `interrupt-process'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (boundp 'interrupt-process-functions)) @@ -4388,10 +4558,13 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; order to establish the connection prior running an asynchronous ;; process. (let ((default-directory (file-truename tramp-test-temporary-file-directory)) + (delete-exited-processes t) kill-buffer-query-functions proc) (unwind-protect (with-temp-buffer - (setq proc (start-file-process "test" (current-buffer) "sleep" "10")) + (setq proc (start-file-process-shell-command + "test" (current-buffer) + "trap 'echo boom; exit 1' 2; sleep 100")) (should (processp proc)) (should (process-live-p proc)) (should (equal (process-status proc) 'run)) @@ -4399,7 +4572,8 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (should (interrupt-process proc)) ;; Let the process accept the interrupt. (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output proc nil nil 0))) + (while (process-live-p proc) + (while (accept-process-output proc 0 nil t)))) (should-not (process-live-p proc)) ;; An interrupted process cannot be interrupted, again. (should-error @@ -4409,14 +4583,24 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; Cleanup. (ignore-errors (delete-process proc))))) +(defun tramp--test-async-shell-command + (command output-buffer &optional error-buffer input) + "Like `async-shell-command', reading the output. +INPUT, if non-nil, is a string sent to the process." + (async-shell-command command output-buffer error-buffer) + (let ((proc (get-buffer-process output-buffer)) + (delete-exited-processes t)) + (when (stringp input) + (process-send-string proc input)) + (with-timeout + ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) + (while (or (accept-process-output proc nil nil t) (process-live-p proc)))) + (accept-process-output proc nil nil t))) + (defun tramp--test-shell-command-to-string-asynchronously (command) "Like `shell-command-to-string', but for asynchronous processes." (with-temp-buffer - (async-shell-command command (current-buffer)) - (with-timeout - ((if (getenv "EMACS_EMBA_CI") 30 10) (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) + (tramp--test-async-shell-command command (current-buffer)) (buffer-substring-no-properties (point-min) (point-max)))) (ert-deftest tramp-test32-shell-command () @@ -4427,6 +4611,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) (let ((tmp-name (tramp--test-make-temp-name nil quoted)) @@ -4435,111 +4620,295 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (inhibit-message t) kill-buffer-query-functions) - ;; Test ordinary `shell-command'. - (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - (should - (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) - (buffer-string)))) + (dolist (this-shell-command + '(;; Synchronously. + shell-command + ;; Asynchronously. + tramp--test-async-shell-command)) - ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `shell-command' with error buffer. - (let ((stderr (generate-new-buffer "*stderr*"))) + ;; Test ordinary `{async-}shell-command'. (unwind-protect (with-temp-buffer - (shell-command "error" (current-buffer) stderr) - (should (= (point-min) (point-max))) + (write-region "foo" nil tmp-name) + (should (file-exists-p tmp-name)) + (funcall + this-shell-command + (format "ls %s" (file-name-nondirectory tmp-name)) + (current-buffer)) + ;; `ls' could produce colorized output. + (goto-char (point-min)) + (while + (re-search-forward tramp-display-escape-sequence-regexp nil t) + (replace-match "" nil nil)) (should - (string-match - "error:.+not found" - (with-current-buffer stderr (buffer-string))))) + (string-equal + (format "%s\n" (file-name-nondirectory tmp-name)) + (buffer-string)))) ;; Cleanup. - (ignore-errors (kill-buffer stderr)))) + (ignore-errors (delete-file tmp-name))) - ;; Test ordinary `async-shell-command'. + ;; Test `{async-}shell-command' with error buffer. + (let ((stderr (generate-new-buffer "*stderr*"))) + (unwind-protect + (with-temp-buffer + (funcall + this-shell-command + "echo foo >&2; echo bar" (current-buffer) stderr) + (should (string-equal "bar\n" (buffer-string))) + ;; Check stderr. + (with-current-buffer stderr + (should (string-equal "foo\n" (buffer-string))))) + + ;; Cleanup. + (ignore-errors (kill-buffer stderr))))) + + ;; Test sending string to `async-shell-command'. (unwind-protect (with-temp-buffer (write-region "foo" nil tmp-name) (should (file-exists-p tmp-name)) - (async-shell-command - (format "ls %s" (file-name-nondirectory tmp-name)) - (current-buffer)) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) + (tramp--test-async-shell-command + "read line; ls $line" (current-buffer) nil + ;; String to be sent. + (format "%s\n" (file-name-nondirectory tmp-name))) (should (string-equal - (format "%s\n" (file-name-nondirectory tmp-name)) + ;; tramp-adb.el echoes, so we must add the string. + (if (tramp--test-adb-p) + (format + "%s\n%s\n" + (file-name-nondirectory tmp-name) + (file-name-nondirectory tmp-name)) + (format "%s\n" (file-name-nondirectory tmp-name))) (buffer-string)))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) + (ignore-errors (delete-file tmp-name))))) - ;; Test sending string to `async-shell-command'. + ;; Test `async-shell-command-width'. It exists since Emacs 26.1, + ;; but seems to work since Emacs 27.1 only. + (when (and (tramp--test-sh-p) (tramp--test-emacs27-p)) + (let* ((async-shell-command-width 1024) + (default-directory tramp-test-temporary-file-directory) + (cols (ignore-errors + (read (tramp--test-shell-command-to-string-asynchronously + "tput cols"))))) + (when (natnump cols) + (should (= cols async-shell-command-width)))))) + +;; This test is inspired by Bug#39067. +(ert-deftest tramp-test32-shell-command-dont-erase-buffer () + "Check `shell-command-dont-erase-buffer'." + :tags '(:expensive-test) + (skip-unless (tramp--test-enabled)) + (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) + ;; Prior Emacs 27, `shell-command-dont-erase-buffer' wasn't working properly. + (skip-unless (tramp--test-emacs27-p)) + + ;; We check both the local and remote case, in order to guarantee + ;; that they behave similar. + (dolist (default-directory + `(,temporary-file-directory ,tramp-test-temporary-file-directory)) + (let ((buffer (generate-new-buffer "foo")) + ;; Suppress nasty messages. + (inhibit-message t) + point kill-buffer-query-functions) (unwind-protect - (with-temp-buffer - (write-region "foo" nil tmp-name) - (should (file-exists-p tmp-name)) - (async-shell-command "read line; ls $line" (current-buffer)) - (process-send-string - (get-buffer-process (current-buffer)) - (format "%s\n" (file-name-nondirectory tmp-name))) - ;; Read output. - (with-timeout (10 (tramp--test-timeout-handler)) - (while (accept-process-output - (get-buffer-process (current-buffer)) nil nil t))) - ;; `ls' could produce colorized output. - (goto-char (point-min)) - (while - (re-search-forward tramp-display-escape-sequence-regexp nil t) - (replace-match "" nil nil)) - ;; We cannot use `string-equal', because tramp-adb.el - ;; echoes also the sent string. - (should - (string-match - (format "\\`%s" (regexp-quote (file-name-nondirectory tmp-name))) - (buffer-string)))) + (progn + ;; Don't erase if buffer is the current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if the buffer is not current one. Point is not moved. + (let (shell-command-dont-erase-buffer) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "baz\n" (buffer-string))) + (should (= point (point))) + (should-not (= (point) (point-max))))) + + ;; Erase if buffer is the current one, but + ;; `shell-command-dont-erase-buffer' is set to `erase'. + ;; There is no point to check point. + (let ((shell-command-dont-erase-buffer 'erase)) + (with-temp-buffer + (insert "bar") + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "baz\n" (buffer-string))) + ;; In the local case, point is not moved after the + ;; inserted text. + (should (= (point) + (if (file-remote-p default-directory) + (point-max) (point-min)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `beg-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'beg-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `end-last-out'. Check point. + (let ((shell-command-dont-erase-buffer 'end-last-out)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-temp-buffer + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "babaz\nr" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to + ;; `save-point'. Check point. + (let ((shell-command-dont-erase-buffer 'save-point)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (goto-char (1- (point-max))) + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (1- (point-max)))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + ;; This does not work as expected. Therefore, we + ;; use the "wrong" string. + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should (= point (point))) + (should-not (= (point) (point-max)))))) + + ;; Don't erase if the buffer is the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-temp-buffer + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (shell-command "echo baz" (current-buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; This does not work as expected in the local case. + ;; Therefore, we negate the test for the time being. + (should-not + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= point (point)))) + (should + (funcall (if (file-remote-p default-directory) #'identity #'not) + (= (point) (point-max)))))) + + ;; Don't erase if the buffer is not the current one and + ;; `shell-command-dont-erase-buffer' is set to a random + ;; value. Check point. + (let ((shell-command-dont-erase-buffer 'random)) + (with-current-buffer buffer + (erase-buffer) + (insert "bar") + (setq point (point)) + (should (string-equal "bar" (buffer-string))) + (should (= (point) (point-max))) + (with-temp-buffer + (shell-command "echo baz" buffer)) + (should (string-equal "barbaz\n" (buffer-string))) + ;; There is still an error in Tramp. + (unless (file-remote-p default-directory) + (should-not (= point (point))) + (should (= (point) (point-max))))))) ;; Cleanup. - (ignore-errors (delete-file tmp-name))) - - ;; Test `async-shell-command-width'. Since Emacs 27.1. - (when (ignore-errors - (and (boundp 'async-shell-command-width) - (zerop (call-process "tput" nil nil nil "cols")) - (zerop (process-file "tput" nil nil nil "cols")))) - (let (async-shell-command-width) - (should - (string-equal - (format "%s\n" (car (process-lines "tput" "cols"))) - (tramp--test-shell-command-to-string-asynchronously - "tput cols"))) - (setq async-shell-command-width 1024) - (should - (string-equal - "1024\n" - (tramp--test-shell-command-to-string-asynchronously - "tput cols")))))))) + (ignore-errors (kill-buffer buffer)))))) ;; This test is inspired by Bug#23952. (ert-deftest tramp-test33-environment-variables () @@ -4547,6 +4916,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (this-shell-command-to-string '(;; Synchronously. @@ -4559,67 +4929,72 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (envvar (concat "VAR_" (upcase (md5 (current-time-string))))) kill-buffer-query-functions) - (unwind-protect - ;; Set a value. - (let ((process-environment - (cons (concat envvar "=foo") process-environment))) - ;; Default value. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))))) - - (unwind-protect - ;; Set the empty value. - (let ((process-environment - (cons (concat envvar "=") process-environment))) - ;; Value is null. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is set. - (should - (string-match - (regexp-quote envvar) - (funcall this-shell-command-to-string "set"))))) + ;; Check INSIDE_EMACS. + (setenv "INSIDE_EMACS") + (should + (string-equal + (format "%s,tramp:%s" emacs-version tramp-version) + (funcall this-shell-command-to-string "echo -n ${INSIDE_EMACS:-bla}"))) + (let ((process-environment + (cons (format "INSIDE_EMACS=%s,foo" emacs-version) + process-environment))) + (should + (string-equal + (format "%s,foo,tramp:%s" emacs-version tramp-version) + (funcall + this-shell-command-to-string "echo -n ${INSIDE_EMACS:-bla}")))) + + ;; Set a value. + (let ((process-environment + (cons (concat envvar "=foo") process-environment))) + ;; Default value. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar))))) + + ;; Set the empty value. + (let ((process-environment + (cons (concat envvar "=") process-environment))) + ;; Value is null. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar)))) + ;; Variable is set. + (should + (string-match + (regexp-quote envvar) + (funcall this-shell-command-to-string "set")))) ;; We force a reconnect, in order to have a clean environment. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) - (unwind-protect - ;; Unset the variable. - (let ((tramp-remote-process-environment - (cons (concat envvar "=foo") - tramp-remote-process-environment))) - ;; Set the initial value, we want to unset below. - (should - (string-match - "foo" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - (let ((process-environment - (cons envvar process-environment))) - ;; Variable is unset. - (should - (string-match - "bla" - (funcall - this-shell-command-to-string - (format "echo -n ${%s:-bla}" envvar)))) - ;; Variable is unset. - (should-not - (string-match - (regexp-quote envvar) - ;; We must remove PS1, the output is truncated otherwise. - (funcall - this-shell-command-to-string "printenv | grep -v PS1"))))))))) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) + ;; Unset the variable. + (let ((tramp-remote-process-environment + (cons (concat envvar "=foo") tramp-remote-process-environment))) + ;; Set the initial value, we want to unset below. + (should + (string-match + "foo" + (funcall + this-shell-command-to-string (format "echo -n ${%s:-bla}" envvar)))) + (let ((process-environment (cons envvar process-environment))) + ;; Variable is unset. + (should + (string-match + "bla" + (funcall + this-shell-command-to-string + (format "echo -n ${%s:-bla}" envvar)))) + ;; Variable is unset. + (should-not + (string-match + (regexp-quote envvar) + ;; We must remove PS1, the output is truncated otherwise. + (funcall + this-shell-command-to-string "printenv | grep -v PS1")))))))) ;; This test is inspired by Bug#27009. (ert-deftest tramp-test33-environment-variables-and-port-numbers () @@ -4628,6 +5003,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; We test it only for the mock-up connection; otherwise there might ;; be problems with the used ports. (skip-unless (and (eq tramp-syntax 'default) (tramp--test-mock-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; We force a reconnect, in order to have a clean environment. (dolist (dir `(,tramp-test-temporary-file-directory @@ -4732,6 +5108,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 26.1. (skip-unless (and (fboundp 'connection-local-set-profile-variables) (fboundp 'connection-local-set-profiles))) @@ -4788,6 +5165,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check `exec-path' and `executable-find'." (skip-unless (tramp--test-enabled)) (skip-unless (or (tramp--test-adb-p) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -4831,6 +5209,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." "Check loooong `tramp-remote-path'." (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) ;; Since Emacs 27.1. (skip-unless (fboundp 'exec-path)) @@ -4838,23 +5217,20 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (default-directory tramp-test-temporary-file-directory) (orig-exec-path (with-no-warnings (exec-path))) (tramp-remote-path tramp-remote-path) - (orig-tramp-remote-path tramp-remote-path)) + (orig-tramp-remote-path tramp-remote-path) + path) (unwind-protect (progn ;; Non existing directories are removed. (setq tramp-remote-path (cons (file-remote-p tmp-name 'localname) tramp-remote-path)) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) orig-exec-path)) (setq tramp-remote-path orig-tramp-remote-path) ;; Double entries are removed. (setq tramp-remote-path (append '("/" "/") tramp-remote-path)) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) (cons "/" orig-exec-path))) (setq tramp-remote-path orig-tramp-remote-path) @@ -4866,26 +5242,30 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (let ((dir (make-temp-file (file-name-as-directory tmp-name) 'dir))) (should (file-directory-p dir)) (setq tramp-remote-path - (cons (file-remote-p dir 'localname) tramp-remote-path) + (append + tramp-remote-path `(,(file-remote-p dir 'localname))) orig-exec-path - (cons (file-remote-p dir 'localname) orig-exec-path)))) - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (append + (butlast orig-exec-path) + `(,(file-remote-p dir 'localname)) + (last orig-exec-path))))) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (should (equal (with-no-warnings (exec-path)) orig-exec-path)) - (should - (string-equal - ;; Ignore trailing newline. - (substring (shell-command-to-string "echo $PATH") nil -1) + ;; Ignore trailing newline. + (setq path (substring (shell-command-to-string "echo $PATH") nil -1)) + ;; The shell doesn't handle such long strings. + (unless (<= (length path) + (tramp-get-connection-property + tramp-test-vec "pipe-buf" 4096)) ;; The last element of `exec-path' is `exec-directory'. - (mapconcat #'identity (butlast orig-exec-path) ":"))) + (should + (string-equal + path (mapconcat #'identity (butlast orig-exec-path) ":")))) ;; The shell "sh" shall always exist. (should (apply #'executable-find '("sh" remote)))) ;; Cleanup. - (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + (tramp-cleanup-connection tramp-test-vec 'keep-debug 'keep-password) (setq tramp-remote-path orig-tramp-remote-path) (ignore-errors (delete-directory tmp-name 'recursive))))) @@ -4894,6 +5274,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." :tags '(:expensive-test) (skip-unless (tramp--test-enabled)) (skip-unless (tramp--test-sh-p)) + (skip-unless (not (tramp--test-crypt-p))) (dolist (quoted (if (tramp--test-expensive-test) '(nil t) '(nil))) ;; We must use `file-truename' for the temporary directory, in @@ -4922,8 +5303,7 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." tramp-remote-process-environment)) ;; We must force a reconnect, in order to activate $BZR_HOME. (tramp-cleanup-connection - (tramp-dissect-file-name tramp-test-temporary-file-directory) - 'keep-debug 'keep-password) + tramp-test-vec 'keep-debug 'keep-password) '(Bzr)) (t nil)))) ;; Suppress nasty messages. @@ -4949,13 +5329,9 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (error (ert-skip "`vc-create-repo' not supported"))) ;; The structure of VC-FILESET is not documented. Let's ;; hope it won't change. - (condition-case nil - (vc-register - (list (car vc-handled-backends) - (list (file-name-nondirectory tmp-name2)))) - ;; `vc-register' has changed its arguments in Emacs - ;; 25.1. Let's skip it for older Emacsen. - (error (skip-unless (tramp--test-emacs25-p)))) + (vc-register + (list (car vc-handled-backends) + (list (file-name-nondirectory tmp-name2)))) ;; vc-git uses an own process sentinel, Tramp's sentinel ;; for flushing the cache isn't used. (dired-uncache (concat (file-remote-p default-directory) "/")) @@ -5212,12 +5588,6 @@ This tests also `make-symbolic-link', `file-truename' and `add-name-to-file'." (delete-directory tmp-file) (should-not (file-exists-p tmp-file)))) -(defun tramp--test-emacs25-p () - "Check for Emacs version >= 25.1. -Some semantics has been changed for there, w/o new functions or -variables, so we check the Emacs version directly." - (>= emacs-major-version 25)) - (defun tramp--test-emacs26-p () "Check for Emacs version >= 26.1. Some semantics has been changed for there, w/o new functions or @@ -5230,6 +5600,12 @@ Some semantics has been changed for there, w/o new functions or variables, so we check the Emacs version directly." (>= emacs-major-version 27)) +(defun tramp--test-emacs28-p () + "Check for Emacs version >= 28.1. +Some semantics has been changed for there, w/o new functions or +variables, so we check the Emacs version directly." + (>= emacs-major-version 28)) + (defun tramp--test-adb-p () "Check, whether the remote host runs Android. This requires restrictions of file name syntax." @@ -5247,6 +5623,10 @@ This does not support some special file names." (string-equal "docker" (file-remote-p tramp-test-temporary-file-directory 'method))) +(defun tramp--test-crypt-p () + "Check, whether the remote directory is crypted" + (tramp-crypt-file-name-p tramp-test-temporary-file-directory)) + (defun tramp--test-ftp-p () "Check, whether an FTP-like method is used. This does not support globbing characters in file names (yet)." @@ -5331,7 +5711,12 @@ This does not support utf8 based file transfer." "Check, whether the locale or remote host runs MS Windows. This requires restrictions of file name syntax." (or (eq system-type 'windows-nt) - (tramp-smb-file-name-p tramp-test-temporary-file-directory))) + (tramp--test-smb-p))) + +(defun tramp--test-smb-p () + "Check, whether the locale or remote host runs MS Windows. +This requires restrictions of file name syntax." + (tramp-smb-file-name-p tramp-test-temporary-file-directory)) (defun tramp--test-check-files (&rest files) "Run a simple but comprehensive test over every file in FILES." @@ -5455,8 +5840,7 @@ This requires restrictions of file name syntax." ;; It does not work in the "smb" case, only relative ;; symlinks to existing files are shown there. (tramp--test-ignore-make-symbolic-link-error - (unless - (tramp-smb-file-name-p tramp-test-temporary-file-directory) + (unless (tramp--test-smb-p) (make-symbolic-link file2 file3) (should (file-symlink-p file3)) (should @@ -5483,6 +5867,7 @@ This requires restrictions of file name syntax." ;; We do not run on macOS due to encoding problems. See ;; Bug#36940. (when (and (tramp--test-expensive-test) (tramp--test-sh-p) + (not (tramp--test-crypt-p)) (not (eq system-type 'darwin))) (dolist (elt files) (let ((envvar (concat "VAR_" (upcase (md5 elt)))) @@ -5650,18 +6035,22 @@ Use the `ls' command." "银河系漫游指南系列" "Автостопом по гала́ктике" ;; Use codepoints without a name. See Bug#31272. - "bung") + "bung" + ;; Use codepoints from Supplementary Multilingual Plane (U+10000 + ;; to U+1FFFF). + "🌈🍒👋") (when (tramp--test-expensive-test) (delete-dups (mapcar - ;; Use all available language specific snippets. Filter out - ;; strings which use unencodable characters. + ;; Use all available language specific snippets. (lambda (x) (and (stringp (setq x (eval (get-language-info (car x) 'sample-text)))) - (not (unencodable-char-position - 0 (length x) file-name-coding-system nil x)) + ;; Filter out strings which use unencodable characters. + (not (and (or (tramp--test-gvfs-p) (tramp--test-smb-p)) + (unencodable-char-position + 0 (length x) file-name-coding-system nil x))) ;; ?\n and ?/ shouldn't be part of any file name. ?\t, ;; ?. and ?? do not work for "smb" method. (replace-regexp-in-string "[\t\n/.?]" "" x))) @@ -5675,6 +6064,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (tramp--test-utf8)) @@ -5689,6 +6079,7 @@ Use the `stat' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-stat v))) @@ -5710,6 +6101,7 @@ Use the `perl' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-parsed-tramp-file-name tramp-test-temporary-file-directory nil (skip-unless (tramp-get-remote-perl v))) @@ -5734,6 +6126,7 @@ Use the `ls' command." (skip-unless (not (tramp--test-windows-nt-and-batch))) (skip-unless (not (tramp--test-windows-nt-and-pscp-psftp-p))) (skip-unless (not (tramp--test-ksh-p))) + (skip-unless (not (tramp--test-crypt-p))) (let ((tramp-connection-properties (append @@ -5753,7 +6146,7 @@ Use the `ls' command." ;; Since Emacs 27.1. (skip-unless (fboundp 'file-system-info)) - ;; `file-system-info' exists since Emacs 27. We don't want to see + ;; `file-system-info' exists since Emacs 27.1. We don't want to see ;; compiler warnings for older Emacsen. (let ((fsi (with-no-warnings (file-system-info tramp-test-temporary-file-directory)))) @@ -5815,6 +6208,7 @@ process sentinels. They shall not disturb each other." ;; remote processes in Emacs. That doesn't work for tramp-adb.el. (skip-unless (or (and (tramp--test-adb-p) (tramp--test-emacs27-p)) (tramp--test-sh-p))) + (skip-unless (not (tramp--test-crypt-p))) (with-timeout (tramp--test-asynchronous-requests-timeout (tramp--test-timeout-handler)) @@ -5875,10 +6269,7 @@ process sentinels. They shall not disturb each other." 0 timer-repeat (lambda () (tramp--test-with-proper-process-name-and-buffer - (get-buffer-process - (tramp-get-buffer - (tramp-dissect-file-name - tramp-test-temporary-file-directory))) + (get-buffer-process (tramp-get-buffer tramp-test-vec)) (when (> (- (time-to-seconds) (time-to-seconds timer-start)) tramp--test-asynchronous-requests-timeout) (tramp--test-timeout-handler)) @@ -6146,12 +6537,14 @@ Since it unloads Tramp, it shall be the last test to run." (and (or (and (boundp x) (null (local-variable-if-set-p x))) (and (functionp x) (null (autoloadp (symbol-function x))))) (string-match "^tramp" (symbol-name x)) + ;; `tramp-completion-mode' is autoloaded in Emacs < 28.1. + (not (eq 'tramp-completion-mode x)) (not (string-match "^tramp\\(-archive\\)?--?test" (symbol-name x))) (not (string-match "unload-hook$" (symbol-name x))) (ert-fail (format "`%s' still bound" x))))) ;; The defstruct `tramp-file-name' and all its internal functions - ;; shall be purged. `cl--find-class' must be protected in Emacs 24. - (with-no-warnings (should-not (cl--find-class 'tramp-file-name))) + ;; shall be purged. + (should-not (cl--find-class 'tramp-file-name)) (mapatoms (lambda (x) (and (functionp x) @@ -6183,6 +6576,8 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * file-equal-p (partly done in `tramp-test21-file-links') ;; * file-in-directory-p ;; * file-name-case-insensitive-p +;; * tramp-get-remote-gid +;; * tramp-get-remote-uid ;; * tramp-set-file-uid-gid ;; * Work on skipped tests. Make a comment, when it is impossible. @@ -6191,11 +6586,10 @@ If INTERACTIVE is non-nil, the tests are run interactively." ;; * Fix `tramp-test06-directory-file-name' for `ftp'. ;; * Investigate, why `tramp-test11-copy-file' and `tramp-test12-rename-file' ;; do not work properly for `nextcloud'. -;; * Fix `tramp-test29-start-file-process' and -;; `tramp-test30-make-process' on MS Windows (`process-send-eof'?). ;; * Implement `tramp-test31-interrupt-process' for `adb'. ;; * Fix Bug#16928 in `tramp-test43-asynchronous-requests'. A remote ;; file name operation cannot run in the timer. Remove `:unstable' tag? (provide 'tramp-tests) + ;;; tramp-tests.el ends here diff --git a/test/lisp/net/webjump-tests.el b/test/lisp/net/webjump-tests.el new file mode 100644 index 00000000000..47569c948f5 --- /dev/null +++ b/test/lisp/net/webjump-tests.el @@ -0,0 +1,73 @@ +;;; webjump-tests.el --- Tests for webjump.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'webjump) + +(ert-deftest webjump-tests-builtin () + (should (equal (webjump-builtin '[name] "gnu.org") "gnu.org"))) + +(ert-deftest webjump-tests-builtin-check-args () + (should (webjump-builtin-check-args [1 2 3] "Foo" 2)) + (should-error (webjump-builtin-check-args [1 2 3] "Foo" 3))) + +(ert-deftest webjump-tests-mirror-default () + (should (equal (webjump-mirror-default + '("https://ftp.gnu.org/pub/gnu/" + "https://ftpmirror.gnu.org")) + "https://ftp.gnu.org/pub/gnu/"))) + +(ert-deftest webjump-tests-null-or-blank-string-p () + (should (webjump-null-or-blank-string-p nil)) + (should (webjump-null-or-blank-string-p "")) + (should (webjump-null-or-blank-string-p " ")) + (should-not (webjump-null-or-blank-string-p " . "))) + +(ert-deftest webjump-tests-url-encode () + (should (equal (webjump-url-encode "") "")) + (should (equal (webjump-url-encode "a b c") "a+b+c")) + (should (equal (webjump-url-encode "foo?") "foo%3F")) + (should (equal (webjump-url-encode "/foo\\") "/foo%5C")) + (should (equal (webjump-url-encode "f&o") "f%26o"))) + +(ert-deftest webjump-tests-url-fix () + (should (equal (webjump-url-fix nil) "")) + (should (equal (webjump-url-fix "/tmp/") "file:///tmp/")) + (should (equal (webjump-url-fix "gnu.org") "http://gnu.org/")) + (should (equal (webjump-url-fix "ftp.x.org") "ftp://ftp.x.org/")) + (should (equal (webjump-url-fix "https://gnu.org") + "https://gnu.org/"))) + +(ert-deftest webjump-tests-url-fix-trailing-slash () + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org") + "https://gnu.org/")) + (should (equal (webjump-url-fix-trailing-slash "https://gnu.org/") + "https://gnu.org/"))) + +(provide 'webjump-tests) +;;; webjump-tests.el ends here diff --git a/test/lisp/password-cache-tests.el b/test/lisp/password-cache-tests.el index 01f4358fc59..55ebbfce7fe 100644 --- a/test/lisp/password-cache-tests.el +++ b/test/lisp/password-cache-tests.el @@ -28,31 +28,31 @@ (ert-deftest password-cache-tests-add-and-remove () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (eq (password-in-cache-p "foo") t)) (password-cache-remove "foo") (should (not (password-in-cache-p "foo"))))) (ert-deftest password-cache-tests-read-from-cache () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (equal (password-read-from-cache "foo") "bar")) (should (not (password-read-from-cache nil))))) (ert-deftest password-cache-tests-in-cache-p () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (password-in-cache-p "foo")) (should (not (password-read-from-cache nil))))) (ert-deftest password-cache-tests-read () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (equal (password-read nil "foo") "bar")))) (ert-deftest password-cache-tests-reset () (let ((password-data (copy-hash-table password-data))) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (password-reset) (should (not (password-in-cache-p "foo"))))) @@ -60,14 +60,14 @@ :tags '(:expensive-test) (let ((password-data (copy-hash-table password-data)) (password-cache-expiry 0.01)) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (sit-for 0.1) (should (not (password-in-cache-p "foo"))))) (ert-deftest password-cache-tests-no-password-cache () (let ((password-data (copy-hash-table password-data)) (password-cache nil)) - (password-cache-add "foo" "bar") + (password-cache-add "foo" (copy-sequence "bar")) (should (not (password-in-cache-p "foo"))) (should (not (password-read-from-cache "foo"))))) diff --git a/test/lisp/play/animate-tests.el b/test/lisp/play/animate-tests.el new file mode 100644 index 00000000000..8af1517ffa4 --- /dev/null +++ b/test/lisp/play/animate-tests.el @@ -0,0 +1,56 @@ +;;; animate-tests.el --- Tests for animate.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'animate) + +(ert-deftest animate-test-birthday-present () + (unwind-protect + (save-window-excursion + (cl-letf (((symbol-function 'sit-for) (lambda (_) nil))) + (animate-birthday-present "foo") + (should (equal (buffer-string) + " + + + + + +Happy Birthday, + Foo + + + You are my sunshine, + My only sunshine. + I'm awful sad that + You've moved away. + + Let's talk together + And love more deeply. + Please bring back + my sunshine + to stay!")))) + (kill-buffer "*A-Present-for-Foo*"))) + +(provide 'animate-tests) +;;; animate-tests.el ends here diff --git a/test/lisp/play/dissociate-tests.el b/test/lisp/play/dissociate-tests.el new file mode 100644 index 00000000000..e8d903109fc --- /dev/null +++ b/test/lisp/play/dissociate-tests.el @@ -0,0 +1,38 @@ +;;; dissociate-tests.el --- Tests for dissociate.el -*- lexical-binding:t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) +(require 'dissociate) + +(ert-deftest dissociate-tests-dissociated-press () + (cl-letf (((symbol-function 'y-or-n-p) (lambda (_) nil)) + ((symbol-function 'random) (lambda (_) 10))) + (save-window-excursion + (with-temp-buffer + (insert "Lorem ipsum dolor sit amet") + (dissociated-press) + (should (string-match-p "dolor sit ametdolor sit amdolor sit amdolor sit am" + (buffer-string))))))) + +(provide 'dissociate-tests) +;;; dissociate-tests.el ends here diff --git a/test/lisp/progmodes/autoconf-tests.el b/test/lisp/progmodes/autoconf-tests.el new file mode 100644 index 00000000000..63cf2889ee2 --- /dev/null +++ b/test/lisp/progmodes/autoconf-tests.el @@ -0,0 +1,55 @@ +;;; autoconf-tests.el --- Tests for autoconf.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'autoconf) +(require 'ert) + +(ert-deftest autoconf-tests-current-defun-function-define () + (with-temp-buffer + (insert "AC_DEFINE(HAVE_RSVG, 1, [Define to 1 if using librsvg.])") + (goto-char (point-min)) + (should-not (autoconf-current-defun-function)) + (forward-char 10) + (should (equal (autoconf-current-defun-function) "HAVE_RSVG")))) + +(ert-deftest autoconf-tests-current-defun-function-subst () + (with-temp-buffer + (insert "AC_SUBST(srcdir)") + (goto-char (point-min)) + (should-not (autoconf-current-defun-function)) + (forward-char 9) + (should (equal (autoconf-current-defun-function) "srcdir")))) + +(ert-deftest autoconf-tests-autoconf-mode-comment-syntax () + (with-temp-buffer + (autoconf-mode) + (insert "dnl Autoconf script for GNU Emacs") + (should (nth 4 (syntax-ppss))))) + +(provide 'autoconf-tests) +;;; autoconf-tests.el ends here diff --git a/test/lisp/progmodes/cc-mode-tests.el b/test/lisp/progmodes/cc-mode-tests.el index 0729841ce6f..64d52a952b6 100644 --- a/test/lisp/progmodes/cc-mode-tests.el +++ b/test/lisp/progmodes/cc-mode-tests.el @@ -40,7 +40,7 @@ (insert content) (setq mode nil) (c-or-c++-mode) - (unless(eq expected mode) + (unless (eq expected mode) (ert-fail (format "expected %s but got %s when testing '%s'" expected mode content))))) @@ -53,11 +53,18 @@ (funcall do-test (concat " * " content) 'c-mode)) '("using \t namespace \t std;" "using \t std::string;" + "using Foo = Bar;" "namespace \t {" "namespace \t foo \t {" - "class \t Blah_42 \t {" + "namespace \t foo::bar \t {" + "inline namespace \t foo \t {" + "inline namespace \t foo::bar \t {" "class \t Blah_42 \t \n" + "class \t Blah_42;" + "class \t Blah_42 \t final {" + "struct \t Blah_42 \t final {" "class \t _42_Blah:public Foo {" + "struct \t _42_Blah:public Foo {" "template \t < class T >" "template< class T >" "#include <string>" @@ -67,6 +74,7 @@ (mapc (lambda (content) (funcall do-test content 'c-mode)) '("struct \t Blah_42 \t {" "struct template {" + "struct Blah;" "#include <string.h>"))))) (ert-deftest c-mode-macro-comment () @@ -78,4 +86,25 @@ (insert macro-string) (c-mode)))) +(ert-deftest c-lineup-ternary-bodies () + "Test for c-lineup-ternary-bodies function" + (with-temp-buffer + (c-mode) + (let* ((common-prefix "int value = condition ") + (expected-column (length common-prefix))) + (dolist (test '(("? a : \n b" . nil) + ("? a \n ::b" . nil) + ("a \n : b" . nil) + ("? a \n : b" . t) + ("? ::a \n : b" . t) + ("? (p ? q : r) \n : b" . t) + ("? p ?: q \n : b" . t) + ("? p ? : q \n : b" . t) + ("? p ? q : r \n : b" . t))) + (delete-region (point-min) (point-max)) + (insert common-prefix (car test)) + (should (equal + (and (cdr test) (vector expected-column)) + (c-lineup-ternary-bodies '(statement-cont . 1)))))))) + ;;; cc-mode-tests.el ends here diff --git a/test/lisp/progmodes/compile-tests.el b/test/lisp/progmodes/compile-tests.el index 75962566f14..cd736497e66 100644 --- a/test/lisp/progmodes/compile-tests.el +++ b/test/lisp/progmodes/compile-tests.el @@ -176,6 +176,9 @@ 13 nil 217 "../src/Lib/System.cpp") ("==1332== by 0x8008621: main (vtest.c:180)" 13 nil 180 "vtest.c") + ;; javac + ("/src/Test.java:5: ';' expected\n foo foo\n ^\n" 1 15 5 "/src/Test.java" 2) + ("e:\\src\\Test.java:7: warning: ';' expected\n foo foo\n ^\n" 1 10 7 "e:\\src\\Test.java" 1) ;; jikes-file jikes-line ("Found 2 semantic errors compiling \"../javax/swing/BorderFactory.java\":" 1 nil nil "../javax/swing/BorderFactory.java") @@ -431,8 +434,8 @@ The test data is in `compile-tests--test-regexps-data'." (compilation-num-warnings-found 0) (compilation-num-infos-found 0)) (mapc #'compile--test-error-line compile-tests--test-regexps-data) - (should (eq compilation-num-errors-found 93)) - (should (eq compilation-num-warnings-found 36)) + (should (eq compilation-num-errors-found 94)) + (should (eq compilation-num-warnings-found 37)) (should (eq compilation-num-infos-found 26))))) (ert-deftest compile-test-grep-regexps () diff --git a/test/lisp/progmodes/elisp-mode-tests.el b/test/lisp/progmodes/elisp-mode-tests.el index 2ba00656862..2de533e5eb9 100644 --- a/test/lisp/progmodes/elisp-mode-tests.el +++ b/test/lisp/progmodes/elisp-mode-tests.el @@ -194,7 +194,7 @@ (dotimes (i 3) (should (equal (elisp-mode-tests--face-propertized-string - (elisp--highlight-function-argument 'foo "(A B C)" (1+ i) "foo: ")) + (elisp--highlight-function-argument 'foo "(A B C)" (1+ i))) (propertize (nth i '("A" "B" "C")) 'face 'eldoc-highlight-function-argument))))) @@ -206,7 +206,7 @@ (cl-flet ((bold-arg (i) (elisp-mode-tests--face-propertized-string (elisp--highlight-function-argument - 'foo "(PROMPT LST &key A B C)" i "foo: ")))) + 'foo "(PROMPT LST &key A B C)" i)))) (should-not (bold-arg 0)) (progn (forward-sexp) (forward-char)) (should (equal (bold-arg 1) "PROMPT")) @@ -226,7 +226,7 @@ (cl-flet ((bold-arg (i) (elisp-mode-tests--face-propertized-string (elisp--highlight-function-argument - 'foo "(X &key A B C)" i "foo: ")))) + 'foo "(X &key A B C)" i)))) (should-not (bold-arg 0)) ;; The `:b' specifies positional arg `X'. (progn (forward-sexp) (forward-char)) diff --git a/test/lisp/progmodes/etags-tests.el b/test/lisp/progmodes/etags-tests.el index f7a5ac4870c..79368cd193f 100644 --- a/test/lisp/progmodes/etags-tests.el +++ b/test/lisp/progmodes/etags-tests.el @@ -1,4 +1,4 @@ -;;; etags-tests.el --- Test suite for etags.el. +;;; etags-tests.el --- Test suite for etags.el. -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/f90-tests.el b/test/lisp/progmodes/f90-tests.el index b6fbac351dc..5115f8ef67e 100644 --- a/test/lisp/progmodes/f90-tests.el +++ b/test/lisp/progmodes/f90-tests.el @@ -1,4 +1,4 @@ -;;; f90-tests.el --- tests for progmodes/f90.el +;;; f90-tests.el --- tests for progmodes/f90.el -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/glasses-tests.el b/test/lisp/progmodes/glasses-tests.el new file mode 100644 index 00000000000..277a9cc1927 --- /dev/null +++ b/test/lisp/progmodes/glasses-tests.el @@ -0,0 +1,101 @@ +;;; glasses-tests.el --- Tests for glasses.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'ert) +(require 'glasses) +(require 'seq) + +(ert-deftest glasses-tests-parenthesis-exception-p () + (with-temp-buffer + (insert "public OnClickListener menuListener() {}") + (let ((glasses-separate-parentheses-exceptions '("^Listen"))) + (should-not (glasses-parenthesis-exception-p 1 (point-max))) + (should (glasses-parenthesis-exception-p 15 (point-max))) + (should-not (glasses-parenthesis-exception-p 24 (point-max))) + (should (glasses-parenthesis-exception-p 28 (point-max)))))) + +(ert-deftest glasses-tests-overlay-p () + (should + (glasses-overlay-p (glasses-make-overlay (point-min) (point-max)))) + (should-not + (glasses-overlay-p (make-overlay (point-min) (point-max))))) + +(ert-deftest glasses-tests-make-overlay-p () + (let ((o (glasses-make-overlay (point-min) (point-max)))) + (should (eq (overlay-get o 'category) 'glasses))) + (let ((o (glasses-make-overlay (point-min) (point-max) 'foo))) + (should (eq (overlay-get o 'category) 'foo)))) + +(ert-deftest glasses-tests-make-readable () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (glasses-make-readable (point-min) (point-max)) + (pcase-let ((`(,o1 ,o2 ,o3) + (sort (overlays-in (point-min) (point-max)) + (lambda (o1 o2) + (< (overlay-start o1) (overlay-start o2)))))) + (should (= (overlay-start o1) 7)) + (should (equal (overlay-get o1 'before-string) + glasses-separator)) + (should (= (overlay-start o2) 17)) + (should (equal (overlay-get o2 'before-string) + glasses-separator)) + (should (= (overlay-start o3) 25)) + (should (equal (overlay-get o3 'before-string) " "))))) + +(ert-deftest glasses-tests-make-readable-dont-separate-parentheses () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (let ((glasses-separate-parentheses-p nil)) + (glasses-make-readable (point-min) (point-max)) + (should-not (overlays-at 25))))) + +(ert-deftest glasses-tests-make-unreadable () + (with-temp-buffer + (insert "pp.setBackgroundResource(R.drawable.button_right);") + (glasses-make-readable (point-min) (point-max)) + (should (seq-some #'glasses-overlay-p + (overlays-in (point-min) (point-max)))) + (glasses-make-unreadable (point-min) (point-max)) + (should-not (seq-some #'glasses-overlay-p + (overlays-in (point-min) (point-max)))))) + +(ert-deftest glasses-tests-convert-to-unreadable () + (with-temp-buffer + (insert "set_Background_Resource(R.button_right);") + (let ((glasses-convert-on-write-p nil)) + (should-not (glasses-convert-to-unreadable)) + (should (equal (buffer-string) + "set_Background_Resource(R.button_right);"))) + (let ((glasses-convert-on-write-p t)) + (should-not (glasses-convert-to-unreadable)) + (should (equal (buffer-string) + "setBackgroundResource(R.button_right);"))))) + +(provide 'glasses-tests) +;;; glasses-tests.el ends here diff --git a/test/lisp/progmodes/pascal-tests.el b/test/lisp/progmodes/pascal-tests.el new file mode 100644 index 00000000000..ed4c6fb03e0 --- /dev/null +++ b/test/lisp/progmodes/pascal-tests.el @@ -0,0 +1,63 @@ +;;; pascal-tests.el --- tests for pascal.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +(require 'ert) +(require 'pascal) + +(ert-deftest pascal-completion () + ;; Bug#41740: completion functions must preserve point. + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; var") + (let* ((point-before (point)) + (completions (pascal-completion "var" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after))))) + + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; function f(x : i") + (let* ((point-before (point)) + (completions (pascal-completion "i" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after))))) + + (let ((pascal-completion-cache nil)) + (with-temp-buffer + (pascal-mode) + (insert "program test; function f(x : integer) : real") + (let* ((point-before (point)) + (completions (pascal-completion "real" nil 'metadata)) + (point-after (point))) + (should (equal completions nil)) + (should (equal point-before point-after)))))) + +(ert-deftest pascal-beg-of-defun () + (with-temp-buffer + (pascal-mode) + (insert "program test; procedure p(") + (forward-char -1) + (pascal-beg-of-defun) + (should (equal (point) 15)))) + +(provide 'pascal-tests) diff --git a/test/lisp/progmodes/ps-mode-tests.el b/test/lisp/progmodes/ps-mode-tests.el index a47abebe6e4..d565b321fdd 100644 --- a/test/lisp/progmodes/ps-mode-tests.el +++ b/test/lisp/progmodes/ps-mode-tests.el @@ -1,4 +1,4 @@ -;;; ps-mode-tests.el --- Test suite for ps-mode +;;; ps-mode-tests.el --- Test suite for ps-mode -*- lexical-binding:t -*- ;; Copyright (C) 2019-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/python-tests.el b/test/lisp/progmodes/python-tests.el index f57150c397e..6b3e63653be 100644 --- a/test/lisp/progmodes/python-tests.el +++ b/test/lisp/progmodes/python-tests.el @@ -1,4 +1,4 @@ -;;; python-tests.el --- Test suite for python.el +;;; python-tests.el --- Test suite for python.el -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -118,7 +118,6 @@ Argument MIN and MAX delimit the region to be returned and default to `point-min' and `point-max' respectively." (let* ((min (or min (point-min))) (max (or max (point-max))) - (buffer (current-buffer)) (buffer-contents (buffer-substring-no-properties min max)) (overlays (sort (overlays-in min max) @@ -154,7 +153,7 @@ The name of this directory depends on `system-type'." sed do eiusmod tempor incididunt ut labore et dolore magna aliqua." (let ((expected (save-excursion - (dotimes (i 3) + (dotimes (_ 3) (re-search-forward "et" nil t)) (forward-char -2) (point)))) @@ -163,7 +162,7 @@ aliqua." ;; one should be returned. (should (= (python-tests-look-at "et" 6 t) expected)) ;; If already looking at STRING, it should skip it. - (dotimes (i 2) (re-search-forward "et")) + (dotimes (_ 2) (re-search-forward "et")) (forward-char -2) (should (= (python-tests-look-at "et") expected))))) @@ -178,7 +177,7 @@ aliqua." (re-search-forward "et" nil t) (forward-char -2) (point)))) - (dotimes (i 3) + (dotimes (_ 3) (re-search-forward "et" nil t)) (should (= (python-tests-look-at "et" -3 t) expected)) (should (= (python-tests-look-at "et" -6 t) expected))))) @@ -2642,7 +2641,7 @@ if x: (ert-deftest python-shell-calculate-process-environment-2 () "Test `python-shell-extra-pythonpaths' modification." (let* ((process-environment process-environment) - (original-pythonpath (setenv "PYTHONPATH" "/path0")) + (_original-pythonpath (setenv "PYTHONPATH" "/path0")) (python-shell-extra-pythonpaths '("/path1" "/path2")) (process-environment (python-shell-calculate-process-environment))) (should (equal (getenv "PYTHONPATH") diff --git a/test/lisp/progmodes/ruby-mode-tests.el b/test/lisp/progmodes/ruby-mode-tests.el index 6bdc7651ff1..9d677a2c27a 100644 --- a/test/lisp/progmodes/ruby-mode-tests.el +++ b/test/lisp/progmodes/ruby-mode-tests.el @@ -1,4 +1,4 @@ -;;; ruby-mode-tests.el --- Test suite for ruby-mode +;;; ruby-mode-tests.el --- Test suite for ruby-mode -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/sql-tests.el b/test/lisp/progmodes/sql-tests.el index 65ed76bfb5d..91805ab7251 100644 --- a/test/lisp/progmodes/sql-tests.el +++ b/test/lisp/progmodes/sql-tests.el @@ -187,7 +187,13 @@ Perform ACTION and validate results" (sql-add-product 'xyz "XyzDb") (should (equal (pp-to-string (assoc 'xyz sql-product-alist)) - "(xyz :name \"XyzDb\")\n")))) + "(xyz :name \"XyzDb\")\n"))) + + (sql-test-product-feature-harness + (sql-add-product 'stu "StuDb" :X 1 :Y "2") + + (should (equal (pp-to-string (assoc 'stu sql-product-alist)) + "(stu :name \"StuDb\" :X 1 :Y \"2\")\n")))) (ert-deftest sql-test-add-existing-product () "Add a product that already exists." diff --git a/test/lisp/progmodes/subword-tests.el b/test/lisp/progmodes/subword-tests.el index 00168c01e13..86e905c8696 100644 --- a/test/lisp/progmodes/subword-tests.el +++ b/test/lisp/progmodes/subword-tests.el @@ -1,4 +1,4 @@ -;;; subword-tests.el --- Testing the subword rules +;;; subword-tests.el --- Testing the subword rules -*- lexical-binding:t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/tcl-tests.el b/test/lisp/progmodes/tcl-tests.el index 75409a62723..fb5a19d3d0c 100644 --- a/test/lisp/progmodes/tcl-tests.el +++ b/test/lisp/progmodes/tcl-tests.el @@ -1,4 +1,4 @@ -;;; tcl-tests.el --- Test suite for tcl-mode +;;; tcl-tests.el --- Test suite for tcl-mode -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. diff --git a/test/lisp/progmodes/xref-tests.el b/test/lisp/progmodes/xref-tests.el index 9c7a9e69658..a4980b2acb1 100644 --- a/test/lisp/progmodes/xref-tests.el +++ b/test/lisp/progmodes/xref-tests.el @@ -1,4 +1,4 @@ -;;; xref-tests.el --- tests for xref +;;; xref-tests.el --- tests for xref -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/replace-tests.el b/test/lisp/replace-tests.el index af765fbe3fa..aed14c33572 100644 --- a/test/lisp/replace-tests.el +++ b/test/lisp/replace-tests.el @@ -1,4 +1,4 @@ -;;; replace-tests.el --- tests for replace.el. +;;; replace-tests.el --- tests for replace.el. -*- lexical-binding:t -*- ;; Copyright (C) 2010-2020 Free Software Foundation, Inc. @@ -546,4 +546,46 @@ Return the last evalled form in BODY." ?q (string= expected (buffer-string)))))) +(defmacro replace-tests-with-highlighted-occurrence (highlight-locus &rest body) + "Helper macro to test the highlight of matches when navigating occur buffer. + +Eval BODY with `next-error-highlight' and `next-error-highlight-no-select' +bound to HIGHLIGHT-LOCUS." + (declare (indent 1) (debug (form body))) + `(let ((regexp "foo") + (next-error-highlight ,highlight-locus) + (next-error-highlight-no-select ,highlight-locus) + (buffer (generate-new-buffer "test")) + (inhibit-message t)) + (unwind-protect + ;; Local bind to disable the deletion of `occur-highlight-overlay' + (cl-letf (((symbol-function 'occur-goto-locus-delete-o) (lambda ()))) + (with-current-buffer buffer (dotimes (_ 3) (insert regexp ?\n))) + (pop-to-buffer buffer) + (occur regexp) + (pop-to-buffer "*Occur*") + (occur-next) + ,@body) + (kill-buffer buffer) + (kill-buffer "*Occur*")))) + +(ert-deftest occur-highlight-occurrence () + "Test for https://debbugs.gnu.org/39121 ." + (let ((alist '((nil . nil) (0.5 . t) (t . t) (fringe-arrow . nil))) + (check-overlays + (lambda (has-ov) + (eq has-ov (not (null (overlays-in (point-min) (point-max)))))))) + (pcase-dolist (`(,highlight-locus . ,has-overlay) alist) + ;; Visiting occurrences + (replace-tests-with-highlighted-occurrence highlight-locus + (occur-mode-goto-occurrence) + (should (funcall check-overlays has-overlay))) + ;; Displaying occurrences + (replace-tests-with-highlighted-occurrence highlight-locus + (occur-mode-display-occurrence) + (with-current-buffer (marker-buffer + (get-text-property (point) 'occur-target)) + (should (funcall check-overlays has-overlay))))))) + + ;;; replace-tests.el ends here diff --git a/test/lisp/shadowfile-tests.el b/test/lisp/shadowfile-tests.el index 650782bc53c..03c62de1fd6 100644 --- a/test/lisp/shadowfile-tests.el +++ b/test/lisp/shadowfile-tests.el @@ -1,4 +1,4 @@ -;;; shadowfile-tests.el --- Tests of shadowfile +;;; shadowfile-tests.el --- Tests of shadowfile -*- lexical-binding:t -*- ;; Copyright (C) 2018-2020 Free Software Foundation, Inc. @@ -70,7 +70,6 @@ (setq password-cache-expiry nil shadow-debug (getenv "EMACS_HYDRA_CI") tramp-verbose 0 - tramp-message-show-message nil ;; On macOS, `temporary-file-directory' is a symlinked directory. temporary-file-directory (file-truename temporary-file-directory) shadow-test-remote-temporary-file-directory @@ -139,9 +138,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -256,9 +255,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -609,9 +608,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -670,9 +669,9 @@ guaranteed by the originator of a cluster definition." ;; We must mock `read-from-minibuffer' and `read-string', in ;; order to avoid interactive arguments. (cl-letf* (((symbol-function #'read-from-minibuffer) - (lambda (&rest args) (pop mocked-input))) + (lambda (&rest _args) (pop mocked-input))) ((symbol-function #'read-string) - (lambda (&rest args) (pop mocked-input)))) + (lambda (&rest _args) (pop mocked-input)))) ;; Cleanup & initialize. (shadow--tests-cleanup) @@ -924,7 +923,7 @@ guaranteed by the originator of a cluster definition." ;; action. (add-function :before (symbol-function #'write-region) - (lambda (&rest args) + (lambda (&rest _args) (when (and (buffer-file-name) mocked-input) (should (equal (buffer-file-name) (pop mocked-input))))) '((name . "write-region-mock"))) diff --git a/test/lisp/simple-tests.el b/test/lisp/simple-tests.el index c8b913b3f1c..4adcacb279b 100644 --- a/test/lisp/simple-tests.el +++ b/test/lisp/simple-tests.el @@ -392,6 +392,48 @@ See bug#35036." (should (equal ?\s (char-syntax ?\n)))))) +;;; undo tests + +(defun simple-tests--exec (cmds) + (dolist (cmd cmds) + (setq last-command this-command) + (setq this-command cmd) + (run-hooks 'pre-command-hook) + (command-execute cmd) + (run-hooks 'post-command-hook) + (undo-boundary))) + +(ert-deftest simple-tests--undo () + (with-temp-buffer + (buffer-enable-undo) + (dolist (x '("a" "b" "c" "d" "e")) + (insert x) + (undo-boundary)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo)) + (should (equal (buffer-string) "abcd")) + (simple-tests--exec '(undo)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(backward-char undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo)) + (should (equal (buffer-string) "abcd")) + (simple-tests--exec '(undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abcde")) + (simple-tests--exec '(undo undo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-only undo-only)) + (should (equal (buffer-string) "a")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abc")) + (simple-tests--exec '(backward-char undo-redo undo-redo)) + (should (equal (buffer-string) "abcde")) + )) + ;;; undo auto-boundary tests (ert-deftest undo-auto-boundary-timer () (should @@ -427,7 +469,7 @@ See bug#35036." (with-temp-buffer (switch-to-buffer (current-buffer)) (setq buffer-undo-list nil) - (insert "a\nb\n\c\n") + (insert "a\nb\nc\n") (goto-char (point-max)) ;; We use a keyboard macro because it adds undo events in the same ;; way as if a user were involved. diff --git a/test/lisp/subr-tests.el b/test/lisp/subr-tests.el index 059d52b1b6f..e2761a96f86 100644 --- a/test/lisp/subr-tests.el +++ b/test/lisp/subr-tests.el @@ -1,4 +1,4 @@ -;;; subr-tests.el --- Tests for subr.el +;;; subr-tests.el --- Tests for subr.el -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. @@ -244,6 +244,27 @@ (error-message-string (should-error (version-to-list "beta22_8alpha3"))) "Invalid version syntax: `beta22_8alpha3' (must start with a number)")))) +(ert-deftest subr-test-version-list-< () + (should (version-list-< '(0) '(1))) + (should (version-list-< '(0 9) '(1 0))) + (should (version-list-< '(1 -1) '(1 0))) + (should (version-list-< '(1 -2) '(1 -1))) + (should (not (version-list-< '(1) '(0)))) + (should (not (version-list-< '(1 1) '(1 0)))) + (should (not (version-list-< '(1) '(1 0)))) + (should (not (version-list-< '(1 0) '(1 0 0))))) + +(ert-deftest subr-test-version-list-= () + (should (version-list-= '(1) '(1))) + (should (version-list-= '(1 0) '(1))) + (should (not (version-list-= '(0) '(1))))) + +(ert-deftest subr-test-version-list-<= () + (should (version-list-<= '(0) '(1))) + (should (version-list-<= '(1) '(1))) + (should (version-list-<= '(1 0) '(1))) + (should (not (version-list-<= '(1) '(0))))) + (defun subr-test--backtrace-frames-with-backtrace-frame (base) "Reference implementation of `backtrace-frames'." (let ((idx 0) diff --git a/test/lisp/tar-mode-tests.el b/test/lisp/tar-mode-tests.el index bc41b863da7..f05389df60f 100644 --- a/test/lisp/tar-mode-tests.el +++ b/test/lisp/tar-mode-tests.el @@ -29,7 +29,8 @@ (cons 420 "rw-r--r--") (cons 292 "r--r--r--") (cons 512 "--------T") - (cons 1024 "-----S---")))) + (cons 1024 "-----S---") + (cons 2048 "--S------")))) (dolist (x alist) (should (equal (cdr x) (tar-grind-file-mode (car x))))))) diff --git a/test/lisp/tempo-tests.el b/test/lisp/tempo-tests.el index 0dd310b8531..bfe475910da 100644 --- a/test/lisp/tempo-tests.el +++ b/test/lisp/tempo-tests.el @@ -216,6 +216,45 @@ (tempo-complete-tag) (should (equal (buffer-string) "Hello, World!")))) +(ert-deftest tempo-define-tag-globally-test () + "Testing usage of a template tag defined from another buffer." + (tempo-define-template "test" '("Hello, World!") "hello") + + (with-temp-buffer + ;; Use a tag in buffer 1 + (insert "hello") + (tempo-complete-tag) + (should (equal (buffer-string) "Hello, World!")) + (erase-buffer) + + ;; Collection should not be dirty + (should-not tempo-dirty-collection) + + ;; Define a tag on buffer 2 + (with-temp-buffer + (tempo-define-template "test2" '("Now expanded.") "mytag")) + + ;; I should be able to use this template back in buffer 1 + (insert "mytag") + (tempo-complete-tag) + (should (equal (buffer-string) "Now expanded.")))) + +(ert-deftest tempo-overwrite-tag-test () + "Testing ability to reassign templates to tags." + (with-temp-buffer + ;; Define a tag and use it + (tempo-define-template "test-tag-1" '("abc") "footag") + (insert "footag") + (tempo-complete-tag) + (should (equal (buffer-string) "abc")) + (erase-buffer) + + ;; Define a new template with the same tag + (tempo-define-template "test-tag-2" '("xyz") "footag") + (insert "footag") + (tempo-complete-tag) + (should (equal (buffer-string) "xyz")))) + (ert-deftest tempo-expand-partial-tag-test () "Testing expansion of a template with a tag, with a partial match." (with-temp-buffer diff --git a/test/lisp/textmodes/conf-mode-tests.el b/test/lisp/textmodes/conf-mode-tests.el index 814cb06b960..7e870269959 100644 --- a/test/lisp/textmodes/conf-mode-tests.el +++ b/test/lisp/textmodes/conf-mode-tests.el @@ -162,7 +162,7 @@ image/tiff tiff tif (ert-deftest conf-test-toml-mode () ;; From `conf-toml-mode' docstring. (with-temp-buffer - (insert "\[entry] + (insert "[entry] value = \"some string\"") (goto-char (point-min)) (conf-toml-mode) diff --git a/test/lisp/textmodes/mhtml-mode-tests.el b/test/lisp/textmodes/mhtml-mode-tests.el index aa5f19efdaa..1840e8b4016 100644 --- a/test/lisp/textmodes/mhtml-mode-tests.el +++ b/test/lisp/textmodes/mhtml-mode-tests.el @@ -1,4 +1,4 @@ -;;; mhtml-mode-tests.el --- Tests for mhtml-mode +;;; mhtml-mode-tests.el --- Tests for mhtml-mode -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/textmodes/po-tests.el b/test/lisp/textmodes/po-tests.el new file mode 100644 index 00000000000..a098290ce15 --- /dev/null +++ b/test/lisp/textmodes/po-tests.el @@ -0,0 +1,68 @@ +;;; po-tests.el --- Tests for po.el -*- lexical-binding: t; -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; Author: Simen Heggestøyl <simenheg@gmail.com> +;; Keywords: + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;; + +;;; Code: + +(require 'po) +(require 'ert) + +(defconst po-tests--buffer-string + "# Norwegian bokmål translation of the GIMP. +# Copyright (C) 1999-2001 Free Software Foundation, Inc. +# +msgid \"\" +msgstr \"\" +\"Project-Id-Version: gimp 2.8.5\\n\" +\"Report-Msgid-Bugs-To: https://gitlab.gnome.org/GNOME/gimp/issues\\n\" +\"POT-Creation-Date: 2013-05-27 14:57+0200\\n\" +\"PO-Revision-Date: 2013-05-27 15:21+0200\\n\" +\"Language: nb\\n\" +\"MIME-Version: 1.0\\n\" +\"Content-Type: text/plain; charset=UTF-8\\n\" +\"Content-Transfer-Encoding: 8bit\\n\" +\"Plural-Forms: nplurals=2; plural=(n != 1);\\n\" + +#: ../desktop/gimp.desktop.in.in.h:1 ../app/about.h:26 +msgid \"GNU Image Manipulation Program\" +msgstr \"GNU bildebehandlingsprogram\" +") + +(ert-deftest po-tests-find-charset () + (with-temp-buffer + (insert po-tests--buffer-string) + (should (equal (po-find-charset (cons nil (current-buffer))) + "UTF-8")))) + +(ert-deftest po-tests-find-file-coding-system-guts () + (with-temp-buffer + (insert po-tests--buffer-string) + (should (equal (po-find-file-coding-system-guts + 'insert-file-contents + (cons "*tmp*" (current-buffer))) + '(utf-8 . nil))))) + +(provide 'po-tests) +;;; po-tests.el ends here diff --git a/test/lisp/textmodes/sgml-mode-tests.el b/test/lisp/textmodes/sgml-mode-tests.el index f0b93e24d2c..a4457307b35 100644 --- a/test/lisp/textmodes/sgml-mode-tests.el +++ b/test/lisp/textmodes/sgml-mode-tests.el @@ -1,4 +1,4 @@ -;;; sgml-mode-tests.el --- Tests for sgml-mode +;;; sgml-mode-tests.el --- Tests for sgml-mode -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/lisp/thingatpt-tests.el b/test/lisp/thingatpt-tests.el index 4edf75edba6..f02aeaeef6a 100644 --- a/test/lisp/thingatpt-tests.el +++ b/test/lisp/thingatpt-tests.el @@ -1,4 +1,4 @@ -;;; thingatpt.el --- tests for thing-at-point. +;;; thingatpt.el --- tests for thing-at-point. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/lisp/time-stamp-tests.el b/test/lisp/time-stamp-tests.el index d229fddc48d..e75e84b0221 100644 --- a/test/lisp/time-stamp-tests.el +++ b/test/lisp/time-stamp-tests.el @@ -38,9 +38,7 @@ (cl-letf (((symbol-function 'time-stamp-conv-warn) (lambda (old-format _new) (ert-fail - (format "Unexpected format warning for '%s'" old-format)))) - ((symbol-function 'system-name) - (lambda () "test-system-name.example.org"))) + (format "Unexpected format warning for '%s'" old-format))))) ;; Not all reference times are used in all tests; ;; suppress the byte compiler's "unused" warning. (list ref-time1 ref-time2 ref-time3) @@ -56,6 +54,13 @@ (apply orig-time-stamp-string-fn ts-format ,reference-time nil)))) ,@body)) +(defmacro with-time-stamp-system-name (name &rest body) + "Force (system-name) to return NAME while evaluating BODY." + (declare (indent defun)) + `(cl-letf (((symbol-function 'system-name) + (lambda () ,name))) + ,@body)) + (defmacro time-stamp-should-warn (form) "Similar to `should' but verifies that a format warning is generated." `(let ((warning-count 0)) @@ -170,6 +175,20 @@ ;; triggering the tests above. (time-stamp))))))) +(ert-deftest time-stamp-custom-format-tabs-expand () + "Test that Tab characters expand in the format but not elsewhere." + (with-time-stamp-test-env + (let ((time-stamp-start "Updated in: <\t") + ;; Tabs in the format should expand + (time-stamp-format "\t%Y\t") + (time-stamp-end "\t>")) + (with-time-stamp-test-time ref-time1 + (with-temp-buffer + (insert "Updated in: <\t\t>") + (time-stamp) + (should (equal (buffer-string) + "Updated in: <\t 2006 \t>"))))))) + (ert-deftest time-stamp-custom-inserts-lines () "Test that time-stamp inserts lines or not, as directed." (with-time-stamp-test-env @@ -194,19 +213,46 @@ (time-stamp) (should (equal (buffer-string) buffer-expected-2line))))))) +(ert-deftest time-stamp-custom-end () + "Test that time-stamp finds the end pattern on the correct line." + (with-time-stamp-test-env + (let ((time-stamp-start "Updated on: <") + (time-stamp-format "%Y-%m-%d") + (time-stamp-end ">") ;changed later in the test + (buffer-original-contents "Updated on: <\n>\n") + (buffer-expected-time-stamped "Updated on: <2006-01-02\n>\n")) + (with-time-stamp-test-time ref-time1 + (with-temp-buffer + (insert buffer-original-contents) + ;; time-stamp-end is not on same line, should not be seen + (time-stamp) + (should (equal (buffer-string) buffer-original-contents)) + + ;; add a newline to time-stamp-end, so it starts on same line + (setq time-stamp-end "\n>") + (time-stamp) + (should (equal (buffer-string) buffer-expected-time-stamped))))))) + (ert-deftest time-stamp-custom-count () "Test that time-stamp updates no more than time-stamp-count templates." (with-time-stamp-test-env (let ((time-stamp-start "TS: <") (time-stamp-format "%Y-%m-%d") - (time-stamp-count 1) ;changed later in the test + (time-stamp-count 0) ;changed later in the test (buffer-expected-once "TS: <2006-01-02>\nTS: <>") (buffer-expected-twice "TS: <2006-01-02>\nTS: <2006-01-02>")) (with-time-stamp-test-time ref-time1 (with-temp-buffer (insert "TS: <>\nTS: <>") (time-stamp) + ;; even with count = 0, expect one time stamp + (should (equal (buffer-string) buffer-expected-once))) + (with-temp-buffer + (setq time-stamp-count 1) + (insert "TS: <>\nTS: <>") + (time-stamp) (should (equal (buffer-string) buffer-expected-once)) + (setq time-stamp-count 2) (time-stamp) (should (equal (buffer-string) buffer-expected-twice))))))) @@ -488,26 +534,35 @@ (ert-deftest time-stamp-format-non-date-conversions () "Test time-stamp formats for non-date items." (with-time-stamp-test-env - ;; implemented and documented since 1995 - (should (equal (time-stamp-string "%%" ref-time1) "%")) ;% last char - (should (equal (time-stamp-string "%%P" ref-time1) "%P")) ;% not last char - (should (equal (time-stamp-string "%f" ref-time1) "time-stamped-file")) - (should - (equal (time-stamp-string "%F" ref-time1) "/emacs/test/time-stamped-file")) - (should (equal (time-stamp-string "%h" ref-time1) "test-mail-host-name")) - ;; documented 1995-2019 - (should (equal - (time-stamp-string "%s" ref-time1) "test-system-name.example.org")) - (should (equal (time-stamp-string "%U" ref-time1) "100%d Tester")) - (should (equal (time-stamp-string "%u" ref-time1) "test-logname")) - ;; implemented since 2001, documented since 2019 - (should (equal (time-stamp-string "%L" ref-time1) "100%d Tester")) - (should (equal (time-stamp-string "%l" ref-time1) "test-logname")) - ;; implemented since 2007, documented since 2019 - (should (equal - (time-stamp-string "%Q" ref-time1) "test-system-name.example.org")) - (should (equal - (time-stamp-string "%q" ref-time1) "test-system-name")))) + (with-time-stamp-system-name "test-system-name.example.org" + ;; implemented and documented since 1995 + (should (equal (time-stamp-string "%%" ref-time1) "%")) ;% last char + (should (equal (time-stamp-string "%%P" ref-time1) "%P")) ;% not last char + (should (equal (time-stamp-string "%f" ref-time1) "time-stamped-file")) + (should (equal (time-stamp-string "%F" ref-time1) + "/emacs/test/time-stamped-file")) + (with-temp-buffer + (should (equal (time-stamp-string "%f" ref-time1) "(no file)")) + (should (equal (time-stamp-string "%F" ref-time1) "(no file)"))) + (should (equal (time-stamp-string "%h" ref-time1) "test-mail-host-name")) + (let ((mail-host-address nil)) + (should (equal (time-stamp-string "%h" ref-time1) + "test-system-name.example.org"))) + ;; documented 1995-2019 + (should (equal (time-stamp-string "%s" ref-time1) + "test-system-name.example.org")) + (should (equal (time-stamp-string "%U" ref-time1) "100%d Tester")) + (should (equal (time-stamp-string "%u" ref-time1) "test-logname")) + ;; implemented since 2001, documented since 2019 + (should (equal (time-stamp-string "%L" ref-time1) "100%d Tester")) + (should (equal (time-stamp-string "%l" ref-time1) "test-logname")) + ;; implemented since 2007, documented since 2019 + (should (equal (time-stamp-string "%Q" ref-time1) + "test-system-name.example.org")) + (should (equal (time-stamp-string "%q" ref-time1) "test-system-name"))) + (with-time-stamp-system-name "sysname-no-dots" + (should (equal (time-stamp-string "%Q" ref-time1) "sysname-no-dots")) + (should (equal (time-stamp-string "%q" ref-time1) "sysname-no-dots"))))) (ert-deftest time-stamp-format-ignored-modifiers () "Test additional args allowed (but ignored) to allow for future expansion." @@ -538,6 +593,13 @@ ;;; Tests of helper functions +(ert-deftest time-stamp-helper-string-defaults () + "Test that time-stamp-string defaults its format to time-stamp-format." + (with-time-stamp-test-env + (should (equal (time-stamp-string nil ref-time1) + (time-stamp-string time-stamp-format ref-time1))) + (should (equal (time-stamp-string 'not-a-string ref-time1) nil)))) + (ert-deftest time-stamp-helper-zone-type-p () "Test time-stamp-zone-type-p." (should (time-stamp-zone-type-p t)) diff --git a/test/lisp/url/url-auth-tests.el b/test/lisp/url/url-auth-tests.el index c574f3d373b..d3acdef8535 100644 --- a/test/lisp/url/url-auth-tests.el +++ b/test/lisp/url/url-auth-tests.el @@ -1,4 +1,4 @@ -;;; url-auth-tests.el --- Test suite for url-auth. +;;; url-auth-tests.el --- Test suite for url-auth. -*- lexical-binding:t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-expand-tests.el b/test/lisp/url/url-expand-tests.el index 553bcf67bd2..6e0ce869502 100644 --- a/test/lisp/url/url-expand-tests.el +++ b/test/lisp/url/url-expand-tests.el @@ -1,4 +1,4 @@ -;;; url-expand-tests.el --- Test suite for relative URI/URL resolution. +;;; url-expand-tests.el --- Test suite for relative URI/URL resolution. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-parse-tests.el b/test/lisp/url/url-parse-tests.el index 98e6dcb9aed..6ec46479a6f 100644 --- a/test/lisp/url/url-parse-tests.el +++ b/test/lisp/url/url-parse-tests.el @@ -1,4 +1,4 @@ -;;; url-parse-tests.el --- Test suite for URI/URL parsing. +;;; url-parse-tests.el --- Test suite for URI/URL parsing. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-tramp-tests.el b/test/lisp/url/url-tramp-tests.el index d6f830afcf2..965b9ea0888 100644 --- a/test/lisp/url/url-tramp-tests.el +++ b/test/lisp/url/url-tramp-tests.el @@ -1,4 +1,4 @@ -;;; url-tramp-tests.el --- Test suite for Tramp / URL conversion. +;;; url-tramp-tests.el --- Test suite for Tramp / URL conversion. -*- lexical-binding:t -*- ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. diff --git a/test/lisp/url/url-util-tests.el b/test/lisp/url/url-util-tests.el index fd3a8d6e108..0416331b032 100644 --- a/test/lisp/url/url-util-tests.el +++ b/test/lisp/url/url-util-tests.el @@ -1,4 +1,4 @@ -;;; url-util-tests.el --- Test suite for url-util. +;;; url-util-tests.el --- Test suite for url-util. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/lisp/vc/add-log-tests.el b/test/lisp/vc/add-log-tests.el index fc928b02c3b..f256945ee42 100644 --- a/test/lisp/vc/add-log-tests.el +++ b/test/lisp/vc/add-log-tests.el @@ -1,4 +1,4 @@ -;;; add-log-tests.el --- Test suite for add-log. +;;; add-log-tests.el --- Test suite for add-log. -*- lexical-binding:t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -25,12 +25,12 @@ (require 'ert) (require 'add-log) -(defmacro add-log-current-defun-deftest (name doc major-mode +(defmacro add-log-current-defun-deftest (name doc mode content marker expected-defun) "Generate an ert test for mode-own `add-log-current-defun-function'. -Run `add-log-current-defun' at the point where MARKER specifies in a -buffer which content is CONTENT under MAJOR-MODE. Then it compares the -result with EXPECTED-DEFUN." +Run `add-log-current-defun' at the point where MARKER specifies +in a buffer which content is CONTENT under major mode MODE. Then +it compares the result with EXPECTED-DEFUN." (let ((xname (intern (concat "add-log-current-defun-test-" (symbol-name name) )))) @@ -39,7 +39,7 @@ result with EXPECTED-DEFUN." (with-temp-buffer (insert ,content) (goto-char (point-min)) - (funcall ',major-mode) + (funcall ',mode) (should (equal (when (search-forward ,marker nil t) (replace-match "" nil t) (add-log-current-defun)) diff --git a/test/lisp/vc/diff-mode-tests.el b/test/lisp/vc/diff-mode-tests.el index 26e9f26fe24..e497ed204df 100644 --- a/test/lisp/vc/diff-mode-tests.el +++ b/test/lisp/vc/diff-mode-tests.el @@ -1,3 +1,5 @@ +;;; diff-mode-tests.el --- Tests for diff-mode.el -*- lexical-binding:t -*- + ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. ;; Author: Dima Kogan <dima@secretsauce.net> diff --git a/test/lisp/vc/ediff-ptch-tests.el b/test/lisp/vc/ediff-ptch-tests.el index ab44e23033c..a3a592bb623 100644 --- a/test/lisp/vc/ediff-ptch-tests.el +++ b/test/lisp/vc/ediff-ptch-tests.el @@ -1,4 +1,4 @@ -;;; ediff-ptch-tests.el --- Tests for ediff-ptch.el +;;; ediff-ptch-tests.el --- Tests for ediff-ptch.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/vc/smerge-mode-tests.el b/test/lisp/vc/smerge-mode-tests.el index c76fc172402..5b15a0931d1 100644 --- a/test/lisp/vc/smerge-mode-tests.el +++ b/test/lisp/vc/smerge-mode-tests.el @@ -1,3 +1,5 @@ +;;; smerge-mode-tests.el --- Tests for smerge-mode.el -*- lexical-binding:t -*- + ;; Copyright (C) 2017-2020 Free Software Foundation, Inc. ;; Maintainer: emacs-devel@gnu.org diff --git a/test/lisp/vc/vc-hg-tests.el b/test/lisp/vc/vc-hg-tests.el index 01d197574fc..e4a20bbf2da 100644 --- a/test/lisp/vc/vc-hg-tests.el +++ b/test/lisp/vc/vc-hg-tests.el @@ -1,4 +1,4 @@ -;;; vc-hg-tests.el --- tests for vc/vc-hg.el +;;; vc-hg-tests.el --- tests for vc/vc-hg.el -*- lexical-binding:t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/lisp/vc/vc-tests.el b/test/lisp/vc/vc-tests.el index 43d24486ed1..8e5cc95ec94 100644 --- a/test/lisp/vc/vc-tests.el +++ b/test/lisp/vc/vc-tests.el @@ -1,4 +1,4 @@ -;;; vc-tests.el --- Tests of different backends of vc.el +;;; vc-tests.el --- Tests of different backends of vc.el -*- lexical-binding:t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. @@ -224,11 +224,10 @@ For backends which don't support it, `vc-not-supported' is signaled." (defmacro vc-test--run-maybe-unsupported-function (func &rest args) "Run FUNC with ARGS as arguments. Catch the `vc-not-supported' error." - `(let (err) - (condition-case err - (funcall ,func ,@args) - (vc-not-supported 'vc-not-supported) - (t (signal (car err) (cdr err)))))) + `(condition-case err + (funcall ,func ,@args) + (vc-not-supported 'vc-not-supported) + (t (signal (car err) (cdr err))))) (defun vc-test--register (backend) "Register and unregister a file. diff --git a/test/lisp/version-tests.el b/test/lisp/version-tests.el new file mode 100644 index 00000000000..8fbd4a19fc5 --- /dev/null +++ b/test/lisp/version-tests.el @@ -0,0 +1,31 @@ +;;; version-tests.el --- Tests for version.el -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(ert-deftest test-emacs-version () + (should (string-match emacs-version (emacs-version))) + (should (string-match system-configuration (emacs-version)))) + +(provide 'version-tests) +;;; version-tests.el ends here diff --git a/test/lisp/xml-tests.el b/test/lisp/xml-tests.el index 895b68f79af..72c78d00e3e 100644 --- a/test/lisp/xml-tests.el +++ b/test/lisp/xml-tests.el @@ -1,4 +1,4 @@ -;;; xml-parse-tests.el --- Test suite for XML parsing. +;;; xml-parse-tests.el --- Test suite for XML parsing. -*- lexical-binding:t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -164,6 +164,16 @@ Parser is called with and without 'symbol-qnames argument.") (should (equal (cdr xml-parse-test--namespace-attribute-qnames) (xml-parse-region nil nil nil nil 'symbol-qnames))))) +(ert-deftest xml-print-invalid-cdata () + "Check that Bug#41094 is fixed." + (with-temp-buffer + (should (equal (should-error (xml-print '((foo () "\0"))) + :type 'xml-invalid-character) + '(xml-invalid-character 0 1))) + (should (equal (should-error (xml-print '((foo () "\u00FF \xFF"))) + :type 'xml-invalid-character) + '(xml-invalid-character #x3FFFFF 3))))) + ;; Local Variables: ;; no-byte-compile: t ;; End: diff --git a/test/manual/indent/css-mode.css b/test/manual/indent/css-mode.css index ecf6c3c0ca5..041aeec1b15 100644 --- a/test/manual/indent/css-mode.css +++ b/test/manual/indent/css-mode.css @@ -92,5 +92,9 @@ div::before { .foo-bar--baz { --foo-variable: 5px; + --_variable_with_underscores: #fff; + --_variable-starting-with-underscore: none; margin: var(--foo-variable); + color: var(--_variable_with_underscores); + display: var(--_variable-starting-with-underscore); } diff --git a/test/manual/indent/elisp.el b/test/manual/indent/elisp.el new file mode 100644 index 00000000000..f3874b5c3e0 --- /dev/null +++ b/test/manual/indent/elisp.el @@ -0,0 +1,5 @@ +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) diff --git a/test/manual/indent/less-css-mode.less b/test/manual/indent/less-css-mode.less index 36c037450cc..b40a2362e28 100644 --- a/test/manual/indent/less-css-mode.less +++ b/test/manual/indent/less-css-mode.less @@ -1,3 +1,13 @@ +@var-with-dashes: #428bca; +@var_with_underscores: 10px; +@_var-starting-with-underscore: none; + +body { + background: @var-with-dashes; + padding: @var_with_underscores; + display: @_var-starting-with-underscore; +} + .desktop-and-old-ie(@rules) { @media screen and (min-width: 1200) { @rules(); } html.lt-ie9 & { @rules(); } diff --git a/test/manual/indent/lisp.lisp b/test/manual/indent/lisp.lisp new file mode 100644 index 00000000000..f3874b5c3e0 --- /dev/null +++ b/test/manual/indent/lisp.lisp @@ -0,0 +1,5 @@ +(defun x () + (print (quote ( thingy great + stuff))) + (print (quote (thingy great + stuff)))) diff --git a/test/manual/indent/scss-mode.scss b/test/manual/indent/scss-mode.scss index a3dd41eeb47..189ec4e22ac 100644 --- a/test/manual/indent/scss-mode.scss +++ b/test/manual/indent/scss-mode.scss @@ -41,9 +41,13 @@ p.#{$name} var article[role="main"] { $toto: 500 !global; $var-with-default: 300 !default; + $var_with_underscores: #fff; + $_var-starting-with-underscore: none; float: left !important; width: 600px / 888px * 100%; height: 100px / 888px * 100%; + color: $var_with_underscores; + display: $_var-starting-with-underscore; } %placeholder { diff --git a/test/src/alloc-tests.el b/test/src/alloc-tests.el index 4eb776a0555..aa1ab1648f8 100644 --- a/test/src/alloc-tests.el +++ b/test/src/alloc-tests.el @@ -51,3 +51,10 @@ (should-not (eq x y)) (dotimes (i 4) (should (eql (aref x i) (aref y i)))))) + +;; Bug#39207 +(ert-deftest aset-nbytes-change () + (let ((s (make-string 1 ?a))) + (dolist (c (list 10003 ?b 128 ?c ?d (max-char) ?e)) + (aset s 0 c) + (should (equal s (make-string 1 c)))))) diff --git a/test/src/buffer-tests.el b/test/src/buffer-tests.el index 60d29dd3a12..0db66f97517 100644 --- a/test/src/buffer-tests.el +++ b/test/src/buffer-tests.el @@ -1314,4 +1314,24 @@ with parameters from the *Messages* buffer modification." (ovshould nonempty-eob-end 4 5) (ovshould empty-eob 5 5))))) +(ert-deftest buffer-multibyte-overlong-sequences () + (dolist (uni '("\xE0\x80\x80" + "\xF0\x80\x80\x80" + "\xF8\x8F\xBF\xBF\x80")) + (let ((multi (string-to-multibyte uni))) + (should + (string-equal + multi + (with-temp-buffer + (set-buffer-multibyte nil) + (insert uni) + (set-buffer-multibyte t) + (buffer-string))))))) + +;; https://debbugs.gnu.org/33492 +(ert-deftest buffer-tests-buffer-local-variables-undo () + "Test that `buffer-undo-list' appears in `buffer-local-variables'." + (with-temp-buffer + (should (assq 'buffer-undo-list (buffer-local-variables))))) + ;;; buffer-tests.el ends here diff --git a/test/src/callproc-tests.el b/test/src/callproc-tests.el index 39d2014488a..1617d5e33d3 100644 --- a/test/src/callproc-tests.el +++ b/test/src/callproc-tests.el @@ -17,6 +17,11 @@ ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +;;; Commentary: +;; +;; Unit tests for src/callproc.c. + ;;; Code: (require 'ert) @@ -60,3 +65,15 @@ (call-process "c:/nul.exe") (error :got-error)))) (should have-called-debugger))) + +(ert-deftest call-process-region-entire-buffer-with-delete () + "Check that Bug#40576 is fixed." + (let ((emacs (expand-file-name invocation-name invocation-directory))) + (skip-unless (file-executable-p emacs)) + (with-temp-buffer + (insert "Buffer contents\n") + (should + (eq (call-process-region nil nil emacs :delete nil nil "--version") 0)) + (should (eq (buffer-size) 0))))) + +;;; callproc-tests.el ends here diff --git a/test/src/charset-tests.el b/test/src/charset-tests.el index 01a68c21a52..9a1d0a46f91 100644 --- a/test/src/charset-tests.el +++ b/test/src/charset-tests.el @@ -1,4 +1,4 @@ -;;; charset-tests.el --- Tests for charset.c +;;; charset-tests.el --- Tests for charset.c -*- lexical-binding: t -*- ;; Copyright 2017-2020 Free Software Foundation, Inc. diff --git a/test/src/chartab-tests.el b/test/src/chartab-tests.el index da320e33b51..0ddea2b338c 100644 --- a/test/src/chartab-tests.el +++ b/test/src/chartab-tests.el @@ -1,4 +1,4 @@ -;;; chartab-tests.el --- Tests for char-tab.c +;;; chartab-tests.el --- Tests for char-tab.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/src/cmds-tests.el b/test/src/cmds-tests.el index 8604d346109..e98e5784609 100644 --- a/test/src/cmds-tests.el +++ b/test/src/cmds-tests.el @@ -1,4 +1,4 @@ -;;; cmds-tests.el --- Testing some Emacs commands +;;; cmds-tests.el --- Testing some Emacs commands -*- lexical-binding: t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/src/coding-tests.el b/test/src/coding-tests.el index 094a1fad8fa..c438ae22ce3 100644 --- a/test/src/coding-tests.el +++ b/test/src/coding-tests.el @@ -1,4 +1,4 @@ -;;; coding-tests.el --- tests for text encoding and decoding +;;; coding-tests.el --- tests for text encoding and decoding -*- lexical-binding: t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -296,7 +296,7 @@ ;;; decoder, not for regression testing. (defun generate-ascii-file () - (dotimes (i 100000) + (dotimes (_i 100000) (insert-char ?a 80) (insert "\n"))) @@ -309,13 +309,13 @@ (insert "\n"))) (defun generate-mostly-nonascii-file () - (dotimes (i 30000) + (dotimes (_i 30000) (insert-char ?a 80) (insert "\n")) - (dotimes (i 20000) + (dotimes (_i 20000) (insert-char ?À 80) (insert "\n")) - (dotimes (i 10000) + (dotimes (_i 10000) (insert-char ?あ 80) (insert "\n"))) @@ -375,6 +375,60 @@ (with-temp-buffer (insert-file-contents (car file)))))) (insert (format "%s: %s\n" (car file) result))))))) +(ert-deftest coding-nocopy-trivial () + "Check that the NOCOPY parameter works for the trivial coding system." + (let ((s "abc")) + (should-not (eq (decode-coding-string s nil nil) s)) + (should (eq (decode-coding-string s nil t) s)) + (should-not (eq (encode-coding-string s nil nil) s)) + (should (eq (encode-coding-string s nil t) s)))) + +(ert-deftest coding-nocopy-ascii () + "Check that the NOCOPY parameter works for ASCII-only strings." + (let* ((uni (apply #'string (number-sequence 0 127))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + ;; Encodings without EOL conversion. + (dolist (coding '(us-ascii-unix iso-latin-1-unix utf-8-unix)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s)) + (should (eq (encode-coding-string s coding t) s)) + (should (eq last-coding-system-used coding))) + + ;; With EOL conversion inhibited. + (let ((inhibit-eol-conversion t)) + (dolist (coding '(us-ascii iso-latin-1 utf-8)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s)) + (should (eq (encode-coding-string s coding t) s)))))) + + ;; Check identity decoding with EOL conversion for ASCII except CR. + (let* ((uni (apply #'string (delq ?\r (number-sequence 0 127)))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + (dolist (coding '(us-ascii-dos iso-latin-1-dos utf-8-dos mac-roman-mac)) + (should-not (eq (decode-coding-string s coding nil) s)) + (should (eq (decode-coding-string s coding t) s))))) + + ;; Check identity encoding with EOL conversion for ASCII except LF. + (let* ((uni (apply #'string (delq ?\n (number-sequence 0 127)))) + (multi (string-to-multibyte uni))) + (dolist (s (list uni multi)) + (dolist (coding '(us-ascii-dos iso-latin-1-dos utf-8-dos mac-roman-mac)) + (should-not (eq (encode-coding-string s coding nil) s)) + (should (eq (encode-coding-string s coding t) s)))))) + + +(ert-deftest coding-check-coding-systems-region () + (should (equal (check-coding-systems-region "aå" nil '(utf-8)) + nil)) + (should (equal (check-coding-systems-region "aåbγc" nil + '(utf-8 iso-latin-1 us-ascii)) + '((iso-latin-1 3) (us-ascii 1 3)))) + (should-error (check-coding-systems-region "å" nil '(bad-coding-system)))) + ;; Local Variables: ;; byte-compile-warnings: (not obsolete) ;; End: diff --git a/test/src/decompress-tests.el b/test/src/decompress-tests.el index 46fd26635c9..0a328396818 100644 --- a/test/src/decompress-tests.el +++ b/test/src/decompress-tests.el @@ -1,4 +1,4 @@ -;;; decompress-tests.el --- Test suite for decompress. +;;; decompress-tests.el --- Test suite for decompress. -*- lexical-binding: t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. diff --git a/test/src/doc-tests.el b/test/src/doc-tests.el index b6026e79c65..50cf0144b80 100644 --- a/test/src/doc-tests.el +++ b/test/src/doc-tests.el @@ -1,4 +1,4 @@ -;;; doc-tests.el --- Tests for doc.c +;;; doc-tests.el --- Tests for doc.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. diff --git a/test/src/emacs-module-tests.el b/test/src/emacs-module-tests.el index 91206156f85..51b2ca0cd51 100644 --- a/test/src/emacs-module-tests.el +++ b/test/src/emacs-module-tests.el @@ -60,8 +60,9 @@ (should (eq 0 (string-match (concat "#<module function " - "\\(at \\(0x\\)?[[:xdigit:]]+\\( from .*\\)?" - "\\|Fmod_test_sum from .*\\)>") + "\\(at \\(0x\\)?[[:xdigit:]]+ " + "with data 0x1234\\( from .*\\)?" + "\\|Fmod_test_sum with data 0x1234 from .*\\)>") (prin1-to-string (nth 1 descr))))) (should (= (nth 2 descr) 3))) (should-error (mod-test-sum "1" 2) :type 'wrong-type-argument) @@ -97,6 +98,7 @@ changes." (rx bos "#<module function " (or "Fmod_test_sum" (and "at 0x" (+ hex-digit))) + " with data 0x1234" (? " from " (* nonl) "mod-test" (* nonl) ) ">" eos) (prin1-to-string func))))) @@ -318,6 +320,9 @@ local reference." (with-temp-buffer (let ((standard-output (current-buffer))) (describe-function-1 #'mod-test-sum) + (goto-char (point-min)) + (while (re-search-forward "`[^']*/data/emacs-module/" nil t) + (replace-match "`data/emacs-module/")) (should (equal (buffer-substring-no-properties 1 (point-max)) (format "a module function in `data/emacs-module/mod-test%s'. @@ -416,4 +421,59 @@ Interactively, you can try hitting \\[keyboard-quit] to quit." (ert-info ((format "input: %d" input)) (should (= (mod-test-double input) (* 2 input)))))) +(ert-deftest module-darwin-secondary-suffix () + "Check that on Darwin, both .so and .dylib suffixes work. +See Bug#36226." + (skip-unless (eq system-type 'darwin)) + (should (member ".dylib" load-suffixes)) + (should (member ".so" load-suffixes)) + ;; Preserve the old `load-history'. This is needed for some of the + ;; other unit tests that indirectly rely on `load-history'. + (let ((load-history load-history) + (dylib (concat mod-test-file ".dylib")) + (so (concat mod-test-file ".so"))) + (should (file-regular-p dylib)) + (should-not (file-exists-p so)) + (add-name-to-file dylib so) + (unwind-protect + (load so nil nil :nosuffix :must-suffix) + (delete-file so)))) + +(ert-deftest module/function-finalizer () + "Test that module function finalizers are properly called." + ;; We create and leak a couple of module functions with attached + ;; finalizer. Creating only one function risks spilling it to the + ;; stack, where it wouldn't be garbage-collected. However, with one + ;; hundred functions, there should be at least one that's + ;; unreachable. + (dotimes (_ 100) + (mod-test-make-function-with-finalizer)) + (cl-destructuring-bind (valid-before invalid-before) + (mod-test-function-finalizer-calls) + (should (zerop invalid-before)) + (garbage-collect) + (cl-destructuring-bind (valid-after invalid-after) + (mod-test-function-finalizer-calls) + (should (zerop invalid-after)) + ;; We don't require exactly 100 invocations of the finalizer, + ;; but at least one. + (should (> valid-after valid-before))))) + +(ert-deftest module/async-pipe () + "Check that writing data from another thread works." + (skip-unless (not (eq system-type 'windows-nt))) ; FIXME! + (with-temp-buffer + (let ((process (make-pipe-process :name "module/async-pipe" + :buffer (current-buffer) + :coding 'utf-8-unix + :noquery t))) + (unwind-protect + (progn + (mod-test-async-pipe process) + (should (accept-process-output process 1)) + ;; The string below must be identical to what + ;; mod-test.c:write_to_pipe produces. + (should (equal (buffer-string) "data from thread"))) + (delete-process process))))) + ;;; emacs-module-tests.el ends here diff --git a/test/src/floatfns-tests.el b/test/src/floatfns-tests.el index c1c2c8996a7..8c56674d4fd 100644 --- a/test/src/floatfns-tests.el +++ b/test/src/floatfns-tests.el @@ -1,4 +1,4 @@ -;;; floatfns-tests.el --- tests for floating point operations +;;; floatfns-tests.el --- tests for floating point operations -*- lexical-binding: t -*- ;; Copyright 2017-2020 Free Software Foundation, Inc. diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el index 60be2c6c2d7..f1faf58659a 100644 --- a/test/src/fns-tests.el +++ b/test/src/fns-tests.el @@ -49,21 +49,21 @@ (should-error (nreverse)) (should-error (nreverse 1)) (should-error (nreverse (make-char-table 'foo))) - (should (equal (nreverse "xyzzy") "yzzyx")) - (let ((A [])) + (should (equal (nreverse (copy-sequence "xyzzy")) "yzzyx")) + (let ((A (vector))) (nreverse A) (should (equal A []))) - (let ((A [0])) + (let ((A (vector 0))) (nreverse A) (should (equal A [0]))) - (let ((A [1 2 3 4])) + (let ((A (vector 1 2 3 4))) (nreverse A) (should (equal A [4 3 2 1]))) - (let ((A [1 2 3 4])) + (let ((A (vector 1 2 3 4))) (nreverse A) (nreverse A) (should (equal A [1 2 3 4]))) - (let* ((A [1 2 3 4]) + (let* ((A (vector 1 2 3 4)) (B (nreverse (nreverse A)))) (should (equal A B)))) @@ -146,13 +146,13 @@ ;; Invalid UTF-8 sequences shall be indicated. How to create such strings? (ert-deftest fns-tests-sort () - (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) + (should (equal (sort (list 9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) '(-1 2 3 4 5 5 7 8 9))) - (should (equal (sort '(9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) + (should (equal (sort (list 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) '(9 8 7 5 5 4 3 2 -1))) - (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (< x y))) + (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (< x y))) [-1 2 3 4 5 5 7 8 9])) - (should (equal (sort '[9 5 2 -1 5 3 8 7 4] (lambda (x y) (> x y))) + (should (equal (sort (vector 9 5 2 -1 5 3 8 7 4) (lambda (x y) (> x y))) [9 8 7 5 5 4 3 2 -1])) (should (equal (sort @@ -172,7 +172,7 @@ ;; Punctuation and whitespace characters are relevant for POSIX. (should (equal - (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") (lambda (a b) (string-collate-lessp a b "POSIX"))) '("1 1" "1 2" "1.1" "1.2" "11" "12"))) ;; Punctuation and whitespace characters are not taken into account @@ -180,7 +180,7 @@ (when (eq system-type 'windows-nt) (should (equal - (sort '("11" "12" "1 1" "1 2" "1.1" "1.2") + (sort (list "11" "12" "1 1" "1 2" "1.1" "1.2") (lambda (a b) (let ((w32-collate-ignore-punctuation t)) (string-collate-lessp @@ -190,7 +190,7 @@ ;; Diacritics are different letters for POSIX, they sort lexicographical. (should (equal - (sort '("Ævar" "Agustín" "Adrian" "Eli") + (sort (list "Ævar" "Agustín" "Adrian" "Eli") (lambda (a b) (string-collate-lessp a b "POSIX"))) '("Adrian" "Agustín" "Eli" "Ævar"))) ;; Diacritics are sorted between similar letters for other locales, @@ -198,7 +198,7 @@ (when (eq system-type 'windows-nt) (should (equal - (sort '("Ævar" "Agustín" "Adrian" "Eli") + (sort (list "Ævar" "Agustín" "Adrian" "Eli") (lambda (a b) (let ((w32-collate-ignore-punctuation t)) (string-collate-lessp @@ -212,7 +212,7 @@ (should (not (string-version-lessp "foo20000.png" "foo12.png"))) (should (string-version-lessp "foo.png" "foo2.png")) (should (not (string-version-lessp "foo2.png" "foo.png"))) - (should (equal (sort '("foo12.png" "foo2.png" "foo1.png") + (should (equal (sort (list "foo12.png" "foo2.png" "foo1.png") 'string-version-lessp) '("foo1.png" "foo2.png" "foo12.png"))) (should (string-version-lessp "foo2" "foo1234")) @@ -432,9 +432,9 @@ (should-error (mapcan)) (should-error (mapcan #'identity)) (should-error (mapcan #'identity (make-char-table 'foo))) - (should (equal (mapcan #'list '(1 2 3)) '(1 2 3))) + (should (equal (mapcan #'list (list 1 2 3)) '(1 2 3))) ;; `mapcan' is destructive - (let ((data '((foo) (bar)))) + (let ((data (list (list 'foo) (list 'bar)))) (should (equal (mapcan #'identity data) '(foo bar))) (should (equal data '((foo bar) (bar)))))) @@ -858,6 +858,22 @@ (puthash k k h))) (should (= 100 (hash-table-count h))))) +(ert-deftest test-sxhash-equal () + (should (= (sxhash-equal (* most-positive-fixnum most-negative-fixnum)) + (sxhash-equal (* most-positive-fixnum most-negative-fixnum)))) + (should (= (sxhash-equal (make-string 1000 ?a)) + (sxhash-equal (make-string 1000 ?a)))) + (should (= (sxhash-equal (point-marker)) + (sxhash-equal (point-marker)))) + (should (= (sxhash-equal (make-vector 1000 (make-string 10 ?a))) + (sxhash-equal (make-vector 1000 (make-string 10 ?a))))) + (should (= (sxhash-equal (make-bool-vector 1000 t)) + (sxhash-equal (make-bool-vector 1000 t)))) + (should (= (sxhash-equal (make-char-table nil (make-string 10 ?a))) + (sxhash-equal (make-char-table nil (make-string 10 ?a))))) + (should (= (sxhash-equal (record 'a (make-string 10 ?a))) + (sxhash-equal (record 'a (make-string 10 ?a)))))) + (ert-deftest test-secure-hash () (should (equal (secure-hash 'md5 "foobar") "3858f62230ac3c915f300c664312c63f")) @@ -874,6 +890,8 @@ (should (equal (secure-hash 'sha512 "foobar") (concat "0a50261ebd1a390fed2bf326f2673c145582a6342d5" "23204973d0219337f81616a8069b012587cf5635f69" - "25f1b56c360230c19b273500ee013e030601bf2425")))) - -(provide 'fns-tests) + "25f1b56c360230c19b273500ee013e030601bf2425"))) + ;; Test that a call to getrandom returns the right format. + ;; This does not test randomness; it's merely a format check. + (should (string-match "\\`[0-9a-f]\\{128\\}\\'" + (secure-hash 'sha512 'iv-auto 100)))) diff --git a/test/src/font-tests.el b/test/src/font-tests.el index 73c2846b032..cfc6f4c31b7 100644 --- a/test/src/font-tests.el +++ b/test/src/font-tests.el @@ -1,4 +1,4 @@ -;;; font-tests.el --- Test suite for font-related functions. +;;; font-tests.el --- Test suite for font-related functions. -*- lexical-binding: t -*- ;; Copyright (C) 2011-2020 Free Software Foundation, Inc. diff --git a/test/src/keymap-tests.el b/test/src/keymap-tests.el index dbf0a7d1229..75f8c0f092e 100644 --- a/test/src/keymap-tests.el +++ b/test/src/keymap-tests.el @@ -1,4 +1,4 @@ -;;; keymap-tests.el --- Test suite for src/keymap.c +;;; keymap-tests.el --- Test suite for src/keymap.c -*- lexical-binding: t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/src/lread-tests.el b/test/src/lread-tests.el index 1426b0145e0..6efd8bed302 100644 --- a/test/src/lread-tests.el +++ b/test/src/lread-tests.el @@ -157,22 +157,6 @@ literals (Bug#20852)." (load "somelib" nil t) (should (string-suffix-p "/somelib.el" (caar load-history))))) -(ert-deftest lread-tests--old-style-backquotes () - "Check that loading doesn't accept old-style backquotes." - (lread-tests--with-temp-file file-name - (write-region "(` (a b))" nil file-name) - (let ((data (should-error (load file-name nil :nomessage :nosuffix)))) - (should (equal (cdr data) - (list (concat (format-message "Loading `%s': " file-name) - "old-style backquotes detected!"))))))) - -(ert-deftest lread-tests--force-new-style-backquotes () - (let ((data (should-error (read "(` (a b))")))) - (should (equal (cdr data) '("Old-style backquotes detected!")))) - (should (equal (let ((force-new-style-backquotes t)) - (read "(` (a b))")) - '(`(a b))))) - (ert-deftest lread-lread--substitute-object-in-subtree () (let ((x (cons 0 1))) (setcar x x) diff --git a/test/src/process-tests.el b/test/src/process-tests.el index 66a76fd33b8..748afe41d2c 100644 --- a/test/src/process-tests.el +++ b/test/src/process-tests.el @@ -1,4 +1,4 @@ -;;; process-tests.el --- Testing the process facilities +;;; process-tests.el --- Testing the process facilities -*- lexical-binding: t -*- ;; Copyright (C) 2013-2020 Free Software Foundation, Inc. @@ -33,7 +33,7 @@ (let ((proc (start-process "test" nil "bash" "-c" "exit 20")) (sentinel-called nil) (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) @@ -88,7 +88,7 @@ :stderr stderr-buffer)) (sentinel-called nil) (start-time (float-time))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) @@ -120,13 +120,13 @@ "exit 20")) :stderr stderr-proc)) (start-time (float-time))) - (set-process-filter proc (lambda (proc input) + (set-process-filter proc (lambda (_proc input) (push input stdout-output))) - (set-process-sentinel proc (lambda (proc msg) + (set-process-sentinel proc (lambda (_proc _msg) (setq sentinel-called t))) - (set-process-filter stderr-proc (lambda (proc input) + (set-process-filter stderr-proc (lambda (_proc input) (push input stderr-output))) - (set-process-sentinel stderr-proc (lambda (proc input) + (set-process-sentinel stderr-proc (lambda (_proc _input) (setq stderr-sentinel-called t))) (while (not (or sentinel-called (> (- (float-time) start-time) diff --git a/test/src/regex-emacs-tests.el b/test/src/regex-emacs-tests.el index 6a661afeff9..f9372e37b11 100644 --- a/test/src/regex-emacs-tests.el +++ b/test/src/regex-emacs-tests.el @@ -161,7 +161,7 @@ what failed, if anything; valid values are 'search-failed, 'compilation-failed and nil. I compare the beginning/end of each group with their expected values. This is done with either BOUNDS-REF or SUBSTRING-REF; one of those should be non-nil. -BOUNDS-REF is a sequence \[start-ref0 end-ref0 start-ref1 +BOUNDS-REF is a sequence [start-ref0 end-ref0 start-ref1 end-ref1 ....] while SUBSTRING-REF is the expected substring obtained by indexing the input string by start/end-ref. @@ -327,7 +327,7 @@ emacs requires an extra symbol character" (defun regex-tests-BOOST-frob-escapes (s ispattern) "Mangle \\ the way it is done in frob_escapes() in regex-tests-BOOST.c in glibc: \\t, \\n, \\r are interpreted; -\\\\, \\^, \{, \\|, \} are unescaped for the string (not +\\\\, \\^, \\{, \\|, \\} are unescaped for the string (not pattern)" ;; this is all similar to (regex-tests-unextend) @@ -505,7 +505,7 @@ differences in behavior.") (cond ;; pattern - ((save-excursion (re-search-forward "^/\\(.*\\)/\\(.*i?\\)$" nil t)) + ((save-excursion (re-search-forward "^/\\(.*\\)/\\(.*\\)$" nil t)) (setq icase (string= "i" (match-string 2)) pattern (regex-tests-unextend (match-string 1)))) diff --git a/test/src/textprop-tests.el b/test/src/textprop-tests.el index 7333444df0b..365d2c7a7b7 100644 --- a/test/src/textprop-tests.el +++ b/test/src/textprop-tests.el @@ -1,4 +1,4 @@ -;;; textprop-tests.el --- Test suite for text properties. +;;; textprop-tests.el --- Test suite for text properties. -*- lexical-binding: t -*- ;; Copyright (C) 2015-2020 Free Software Foundation, Inc. diff --git a/test/src/thread-tests.el b/test/src/thread-tests.el index 5d85fc74e50..df34a2b66eb 100644 --- a/test/src/thread-tests.el +++ b/test/src/thread-tests.el @@ -1,4 +1,4 @@ -;;; threads.el --- tests for threads. +;;; threads.el --- tests for threads. -*- lexical-binding: t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. diff --git a/test/src/timefns-tests.el b/test/src/timefns-tests.el index 62d56ac0d9f..51dd1d1aeb5 100644 --- a/test/src/timefns-tests.el +++ b/test/src/timefns-tests.el @@ -1,4 +1,4 @@ -;;; timefns-tests.el -- tests for timefns.c +;;; timefns-tests.el -- tests for timefns.c -*- lexical-binding: t -*- ;; Copyright (C) 2016-2020 Free Software Foundation, Inc. @@ -124,44 +124,44 @@ ;;; Tests of format-time-string padding (ert-deftest format-time-string-padding-minimal-deletes-unneeded-zeros () - (let ((ref-time (append (encode-time 0 0 0 15 2 2000) '(123450)))) + (let ((ref-time (encode-time '((123450 . 1000000) 0 0 15 2 2000 - - t)))) (should (equal (format-time-string "%-:::z" ref-time "FJT-12") "+12")) - (should (equal (format-time-string "%-N" ref-time) "12345")) - (should (equal (format-time-string "%-6N" ref-time) "12345")) - (should (equal (format-time-string "%-m" ref-time) "2")))) ;not "02" + (should (equal (format-time-string "%-N" ref-time t) "12345")) + (should (equal (format-time-string "%-6N" ref-time t) "12345")) + (should (equal (format-time-string "%-m" ref-time t) "2")))) ;not "02" (ert-deftest format-time-string-padding-minimal-retains-needed-zeros () - (let ((ref-time (append (encode-time 0 0 0 20 10 2000) '(3450)))) + (let ((ref-time (encode-time '((3450 . 1000000) 0 0 20 10 2000 - - t)))) (should (equal (format-time-string "%-z" ref-time "IST-5:30") "+530")) (should (equal (format-time-string "%-4z" ref-time "IST-5:30") "+530")) (should (equal (format-time-string "%4z" ref-time "IST-5:30") "+530")) - (should (equal (format-time-string "%-N" ref-time) "00345")) - (should (equal (format-time-string "%-3N" ref-time) "003")) - (should (equal (format-time-string "%3N" ref-time) "003")) - (should (equal (format-time-string "%-m" ref-time) "10")) ;not "1" - (should (equal (format-time-string "%-1m" ref-time) "10")) ;not "1" - (should (equal (format-time-string "%1m" ref-time) "10")))) ;not "1" + (should (equal (format-time-string "%-N" ref-time t) "00345")) + (should (equal (format-time-string "%-3N" ref-time t) "003")) + (should (equal (format-time-string "%3N" ref-time t) "003")) + (should (equal (format-time-string "%-m" ref-time t) "10")) ;not "1" + (should (equal (format-time-string "%-1m" ref-time t) "10")) ;not "1" + (should (equal (format-time-string "%1m" ref-time t) "10")))) ;not "1" (ert-deftest format-time-string-padding-spaces () - (let ((ref-time (append (encode-time 0 0 0 10 12 2000) '(123000)))) + (let ((ref-time (encode-time '((123000 . 1000000) 0 0 10 12 2000 - - t)))) (should (equal (format-time-string "%_7z" ref-time "CHA-12:45") " +1245")) - (should (equal (format-time-string "%_6N" ref-time) "123 ")) - (should (equal (format-time-string "%_9N" ref-time) "123 ")) - (should (equal (format-time-string "%_12N" ref-time) "123 ")) - (should (equal (format-time-string "%_m" ref-time) "12")) - (should (equal (format-time-string "%_2m" ref-time) "12")) - (should (equal (format-time-string "%_3m" ref-time) " 12")))) + (should (equal (format-time-string "%_6N" ref-time t) "123 ")) + (should (equal (format-time-string "%_9N" ref-time t) "123 ")) + (should (equal (format-time-string "%_12N" ref-time t) "123 ")) + (should (equal (format-time-string "%_m" ref-time t) "12")) + (should (equal (format-time-string "%_2m" ref-time t) "12")) + (should (equal (format-time-string "%_3m" ref-time t) " 12")))) (ert-deftest format-time-string-padding-zeros-adds-on-insignificant-side () "Fractional seconds have a fixed place on the left, and any padding must happen on the right. All other numbers have a fixed place on the right and are padded on the left." - (let ((ref-time (append (encode-time 0 0 0 10 12 2000) '(123000)))) - (should (equal (format-time-string "%3m" ref-time) "012")) + (let ((ref-time (encode-time '((123000 . 1000000) 0 0 10 12 2000 - - t)))) + (should (equal (format-time-string "%3m" ref-time t) "012")) (should (equal (format-time-string "%7z" ref-time "CHA-12:45") "+001245")) - (should (equal (format-time-string "%12N" ref-time) "123000000000")) - (should (equal (format-time-string "%9N" ref-time) "123000000")) - (should (equal (format-time-string "%6N" ref-time) "123000")))) + (should (equal (format-time-string "%12N" ref-time t) "123000000000")) + (should (equal (format-time-string "%9N" ref-time t) "123000000")) + (should (equal (format-time-string "%6N" ref-time t) "123000")))) (ert-deftest time-equal-p-nil-nil () @@ -220,6 +220,9 @@ a fixed place on the right and are padded on the left." '(23752 27217)))) (ert-deftest float-time-precision () + (should (= (float-time '(0 1 0 4025)) 1.000000004025)) + (should (= (float-time '(1000000004025 . 1000000000000)) 1.000000004025)) + (should (< 0 (float-time '(1 . 10000000000)))) (should (< (float-time '(-1 . 10000000000)) 0)) diff --git a/test/src/undo-tests.el b/test/src/undo-tests.el index 995e4365e12..b26a276c61b 100644 --- a/test/src/undo-tests.el +++ b/test/src/undo-tests.el @@ -1,4 +1,4 @@ -;;; undo-tests.el --- Tests of primitive-undo +;;; undo-tests.el --- Tests of primitive-undo -*- lexical-binding: t -*- ;; Copyright (C) 2012-2020 Free Software Foundation, Inc. @@ -452,7 +452,7 @@ Demonstrates bug 25599." (insert ";; aaaaaaaaa ;; bbbbbbbb") (let ((overlay-modified - (lambda (ov after-p _beg _end &optional length) + (lambda (ov after-p _beg _end &optional _length) (unless after-p (when (overlay-buffer ov) (delete-overlay ov)))))) diff --git a/test/src/xfaces-tests.el b/test/src/xfaces-tests.el new file mode 100644 index 00000000000..bde3a354229 --- /dev/null +++ b/test/src/xfaces-tests.el @@ -0,0 +1,50 @@ +;;; xfaces-tests.el --- tests for xfaces.c -*- lexical-binding: t -*- + +;; Copyright (C) 2020 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see <https://www.gnu.org/licenses/>. + +(require 'ert) + +(ert-deftest xfaces-color-distance () + ;; Check symmetry (bug#41544). + (should (equal (color-distance "#222222" "#ffffff") + (color-distance "#ffffff" "#222222")))) + +(ert-deftest xfaces-internal-color-values-from-color-spec () + (should (equal (color-values-from-color-spec "#f05") + '(#xffff #x0000 #x5555))) + (should (equal (color-values-from-color-spec "#1fb0C5") + '(#x1f1f #xb0b0 #xc5c5))) + (should (equal (color-values-from-color-spec "#1f8b0AC5e") + '(#x1f81 #xb0aa #xc5eb))) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e2") + '(#x1f83 #xb0ad #xc5e2))) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e2g") nil)) + (should (equal (color-values-from-color-spec "#1f83b0ADC5e20") nil)) + (should (equal (color-values-from-color-spec "#12345") nil)) + (should (equal (color-values-from-color-spec "rgb:f/23/28a") + '(#xffff #x2323 #x28a2))) + (should (equal (color-values-from-color-spec "rgb:1234/5678/09ab") + '(#x1234 #x5678 #x09ab))) + (should (equal (color-values-from-color-spec "rgb:0//0") nil)) + (should (equal (color-values-from-color-spec "rgbi:0/0.5/0.1") + '(0 32768 6554))) + (should (equal (color-values-from-color-spec "rgbi:1e-3/1.0e-2/1e0") + '(66 655 65535))) + (should (equal (color-values-from-color-spec "rgbi:0/0.5/10") nil))) + +(provide 'xfaces-tests) diff --git a/test/src/xml-tests.el b/test/src/xml-tests.el index 02a52e9115d..d758c8868cf 100644 --- a/test/src/xml-tests.el +++ b/test/src/xml-tests.el @@ -1,4 +1,4 @@ -;;; libxml-parse-tests.el --- Test suite for libxml parsing. +;;; xml-tests.el --- Test suite for libxml parsing. -*- lexical-binding: t -*- ;; Copyright (C) 2014-2020 Free Software Foundation, Inc. |